☰

根据单元格值复制数据范围

tag-icon • tag-icon microsoft-excel
根据单元格值复制数据范围

我有一个包含 A 至 C 列的列表。B 列包含“A”、“B”或“C”。我需要根据 B 列中的值将 A 至 C 列中的所有数据复制到新工作表中。

样本数据

我想在 B 列为“A”时复制到工作表 1，在 B 列为“B”时复制到工作表 2，在 B 列为“C”时复制到工作表 3。

我尝试过使用 VBA For i = 1 to .End(xlUp).Offset(0)，但我该怎么办？我尝试的方法对我来说根本不起作用。

答案1

以下代码假设包含要复制的数据的工作表名为“Main”。它还假设您的“粘贴”工作表包含列标题，因此它将从第 2 行开始粘贴。如果这不是您想要的，请.Offset(1, 0)从执行粘贴的行中删除调用。

您可能希望有比一行更好的错误处理Debug.Print，但我会把这留给您决定。

在 Excel 2007 中测试，并且运行正常。

Sub DoCopy()

  Const copySheetName As String = "Main"
  Dim rw As Integer
  Dim lngRowStart As Long
  Dim lngRowEnd As Long

  Dim copySheet As Excel.Worksheet: Set copySheet = ThisWorkbook.Worksheets(copySheetName)
  Dim pasteSheet As Excel.Worksheet

  lngRowStart = 1 'number of first row containing data to copy
  lngRowEnd = 17  'number of last row containing data to copy

  'the "Copy" sheet be the active sheet in order to copy/paste (avoid run-time error 1004)
  ThisWorkbook.Worksheets(copySheetName).Activate

  For rw = lngRowStart To lngRowEnd

    copySheet.Range(Cells(rw, 1), Cells(rw, 3)).Copy

    Select Case Cells(rw, 2)
      Case "a"
        Set pasteSheet = ThisWorkbook.Worksheets("Sheet1")
      Case "b"
        Set pasteSheet = ThisWorkbook.Worksheets("Sheet2")
      Case "c"
        Set pasteSheet = ThisWorkbook.Worksheets("Sheet3")
      Case Else
        Debug.Print "Invalid Value: " & Cells(rw, 2) & " (row " & rw & ")"
        GoTo SkipRow
    End Select

    pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

SkipRow:
  Next rw

  Application.CutCopyMode = False
  Set copySheet = Nothing
  Set pasteSheet = Nothing
End Sub

答案2

抱歉，我刚好有时间测试这个，但不起作用。它在“ Dim copySheet As Excel.Worksheet: Set copySheet = ThisWorkbook.Worksheets(copySheetName)”期间挂起了

我工作表“数据”中的原始数据，我已将名称更新为 Const copySheetName As String =“data”

你知道为什么它不起作用吗？谢谢。

相关内容