Excel Forum

Code: Select all

Sub Counterdata()
   
 
    Dim historyWks As Worksheet
    Dim inputWks As Worksheet

    Dim nextRow As Long
    Dim oCol As Long

    Dim myRng As Range
    Dim myCopy As String
    Dim myCell As Range
    ActiveSheet.Unprotect Password:="1234" '<==UnProtect
    Sheets("Input").Unprotect Password:="1234"
    'cells to copy from Input sheet - some contain formulas
    myCopy = "c4,c3,c5,c6,c7,c8,e17,e18,e19,e16:g16"

    Set inputWks = Worksheets("Input")
    Set historyWks = Worksheets("Counterdata")

    With historyWks
        nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
    End With

    
    With inputWks
    Set myRng = .Range(myCopy)
        If Not ActiveWorkbook.Saved Then
        Msg = "·èÒ¹¡ÃÍ¡¢éÍÁÙŤú¶éǹËÃ×ÍäÁè?"

        Ans = MsgBox(Msg, vbQuestion + vbYesNo)
        Select Case Ans
            Case vbYes
                ThisWorkbook.Saved = True
            Case vbNo
                 Cancel = True
           
                Exit Sub
          End Select
    End If
    If Application.CountA(myRng) <> myRng.Cells.Count Then
            MsgBox "¡ÃسÒãÊè¢éÍÁÙÅãËé¤Ãº¶éǹ"
            Exit Sub
        End If
    End With

    With historyWks
        'With .Cells(nextRow, "A")
           ' .Value = Now
            '.NumberFormat = "mm/dd/yyyy hh:mm:ss"
        'End With
        '.Cells(nextRow, "B").Value = Application.UserName
        oCol = 1
        For Each myCell In myRng.Cells
            historyWks.Cells(nextRow, oCol).Value = myCell.Value
            oCol = oCol + 1
        Next myCell
    End With
    
    With inputWks
        On Error Resume Next
            Range("E16").Select
            Selection.Copy
            Range("E15").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
            Range("E16").Select
            Application.CutCopyMode = False
            
        End With
    
    'clear input cells that contain constants
    With inputWks
      On Error Resume Next
         With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
             .ClearContents
             Application.GoTo .Cells(1) ', Scroll:=True
         End With
      On Error GoTo 0
    End With
Sheets("Input").Protect Password:="1234" '<==Protect
    ActiveSheet.Unprotect Password:="1234" '<==UnProtect

End Sub

Code: Select all

[code]
Sub Counterdata()
other code
Sheets("Input").Protect Password:="1234" '<==Protect
   ' ActiveSheet.Unprotect Password:="1234" '<==UnProtect
End Sub