input代码需要稍作修改

使用此代码，将指定的单元格复制到数据库工作表中，然后清除下一个条目的数据表单。 我如何修改代码，以便一个（或多个）单元格不被清除？

Option Explicit Sub UpdateLogWorksheet() 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 "sallygary" 'cells to copy from Input sheet - some contain formulas myCopy = "g12,g14,g18,g20,g22,g24,i16,i18,i20,i22,i24,k16,k18,k20,k22,k24,m16,m18,m20,m22,m24,o16,o18,o20,o22,o24,q16,q18,q20,q22,q24,s16,s18,s20,s22,s24,u16,u18,u20,u22,u24" Set inputWks = Worksheets("Input") Set historyWks = Worksheets("1_Data") With historyWks nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row End With With inputWks Set myRng = .Range(myCopy) 'If Application.CountA(myRng) <> myRng.Cells.Count Then ' MsgBox "Please fill in all the cells!" ' Exit Sub 'End If End With With historyWks With .Cells(nextRow, "A") .Value = "e4" .NumberFormat = "mm/dd/yyyy" 'hh:mm:ss End With .Cells(nextRow, "B").Value = Application.UserName oCol = 3 For Each myCell In myRng.Cells historyWks.Cells(nextRow, oCol).Value = myCell.Value oCol = oCol + 1 Next myCell 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 ActiveSheet.Protect "sallygary" Range("g12").Select End Sub 

Answer 1

添加另一个类似于myCopy var的stringvariables。

 dim myCopy as string, myClear as string 'cells to copy from Input sheet - some contain formulas myCopy = "g12,g14,g18,g20,g22,g24,i16,i18,i20,i22,i24,k16,k18,k20,k22,k24,m16,m18,m20,m22,m24,o16,o18,o20,o22,o24,q16,q18,q20,q22,q24,s16,s18,s20,s22,s24,u16,u18,u20,u22,u24" 'cells to CLEAR from Input sheet myClear = "g12,g18,g22,i16,i20,i24,k18,k22,m16,m20,m24,o18,o22,q16,q20,q24,s18,s22,u16,u20,u24" 

现在使用该范围定义来清除单元格内容。

  With .Range(myClear).Cells.SpecialCells(xlCellTypeConstants) .ClearContents Application.GoTo .Cells(1) ', Scroll:=True End With