将行复制到不同的工作表

Question

我有一个包含3个工作表的Excel文件。
如果要在“ 我 Main ”复制整行到第二个工作表“ INS ”。 >”为空，如果 H 列中的单元格为空，我想将整行复制到名为“ SEC ”的第三个工作表中。 Google Sheets Sample of My Workbook

Answer 1

将行复制到不同的工作表

仔细调整常量部分中的数据以适合您的需求。

Option Explicit

Sub CopyData()

  ' Constants
  Const cVntSource As String = "Main"    ' Source Worksheet Name or Index
  Const cLngFirstRow As Long = 2         ' Source First Row of Data Number
  Const cVntTarget1 As String = "INS"    ' Target1 Worksheet Name or Index
  Const cVntTarget2 As String = "SEC"    ' Target2 Worksheet Name or Index
  Const cVntCol1 As Variant = "I"        ' Column Letter or Number for Target1
  Const cVntCol2 As Variant = "H"        ' Column Letter or Number for Target2

  ' Object Variables
  Dim objSource As Worksheet             ' Source Worksheet (object)
  Dim objT1 As Worksheet                 ' Target1 Worksheet (object)
  Dim objT2 As Worksheet                 ' Target2 Worksheet (object)

  ' Other Variables
  Dim lngLastRow As Long                 ' Source Last Row of Data Number
  Dim lngSource As Long                  ' Source Rows Counter
  Dim lngT1 As Long                      ' Target1 Rows Counter
  Dim lngT2 As Long                      ' Target2 Rows Counter

  ' Create object references.
  With ThisWorkbook
    Set objSource = .Worksheets(cVntSource)
    Set objT1 = .Worksheets(cVntTarget1)
    Set objT2 = .Worksheets(cVntTarget2)
  End With

  With objSource

    ' Calculate last row of data in Source Worksheet
    lngLastRow = .UsedRange.Rows.Count + .UsedRange.Row - 1

    ' Calculate first free row in Target Worksheets.
    ' If any of sheets are empty, code will paste starting from row 2.
    lngT1 = objT1.UsedRange.Rows.Count + objT1.UsedRange.Row - 1
    lngT2 = objT2.UsedRange.Rows.Count + objT2.UsedRange.Row - 1

    ' Loop through the cells of Source Worksheet from first to last row of data.
    For lngSource = cLngFirstRow To lngLastRow

      ' Check condition for Target1 Worksheet: Empty cell in column CVntCol1.
      If .Cells(lngSource, cVntCol1) = "" Then ' Cell is empty.
        lngT1 = lngT1 + 1
        .Cells(lngSource, cVntCol1).EntireRow.Copy _
        objT1.Cells(lngT1, 1).EntireRow
'       Else ' Cell is not empty.
      End If

      ' Check condition for Target2 Worksheet: Empty cell in column CVntCol2.
      If .Cells(lngSource, cVntCol2) = "" Then ' Cell is empty.
        lngT2 = lngT2 + 1
        .Cells(lngSource, cVntCol2).EntireRow.Copy _
        objT2.Cells(lngT2, 1).EntireRow
'       Else ' Cell is not empty.
      End If

    Next

  End With

  ' Release object references.
  Set objT2 = Nothing
  Set objT1 = Nothing
  Set objSource = Nothing

End Sub

在Excel中复制空单元格

1 个答案:

将行复制到不同的工作表