循环以将一张表中的列复制到另一张表中的表中

Question

我正在尝试创建一个宏，将“主页”标签中的单列数据复制到不同标签中的表格中。目前，我的宏将列（一次一个单元格，因为列范围是可变的）复制到“Sheet 1”中的表中。我的问题是宏只能工作一次，因为每次运行宏时我都无法弄清楚如何将表中的列向右扩展。这有意义吗？

您可能会问，为什么不手动复制/粘贴表中的数据？我有多个选项卡，我将创建多个宏 - 每个选项卡一个。理想情况下，我将根据粘贴在“主页”标签中的单个列中的信息运行宏，并将作为新列粘贴到它要进入的标签中的表格中。 p>

Sub Sheet3()

Dim i As Long, lastRow As Long

Set NewData = Sheets("Home")
Set Sheet3 = Sheets("Question 3")

lastRow = NewData.Cells(Rows.Count, "B").End(xlUp).Row

For i = 6 To lastRow
    'test if cell is empty
    If NewData.Range("B" & i).Value <> "" Then
        Sheet3.Range("D" & i - 2).Value = NewData.Range("B" & i).Value
    End If
Next i

End Sub

Answer 1

问题是Sheet3 是您的一个工作表的内部名称。无论选项卡上的内容是什么，Sheet3 将始终引用集合中的第三张表。

我的测试工作簿中只有一张工作表，但您可以在 Project Explorer 的屏幕截图中看到它：
您可以看到，即使我已将选项卡重命名为“test”，但在内部仍可以将其在代码中引用为 Sheet1。

简单的做法是将这一行
Set Sheet3 = Sheets("Question 3")
改成这样的
Set otherSheet = Sheets("Question 3")

但是，我建议使用以下解决方案来解决“我有多个选项卡，我将创建多个宏 - 每个选项卡一个。”而不是编写一个 proc专用于每个工作表（或工作表对），编写一个可以多次调用的过程，如下所示：

Option Explicit

Private Sub CopyCells(ByVal sourceSheet As Worksheet, ByVal destSheet As Worksheet, _
                      ByVal sourceCol As Long, ByVal destCol As Long)

  Dim lastRow As Long
  With sourceSheet
    lastRow = .Cells(.Rows.Count, sourceCol).End(xlUp).Row
  End With

  Dim i As Long
  For i = 6 To lastRow
    If sourceSheet.Cells(i, sourceCol).Value2 <> vbNullString Then
      destSheet.Cells(i - 2, destCol).Value2 = sourceSheet.Cells(i, sourceCol).Value2
    End If
  Next i

End Sub

现在，您可以编写一行代码来将单元格从工作表复制到工作表，并对CopyCells 进行多次调用，每个工作表调用一次。例如：

CopyCells(myWB.Sheets("Home"), myWB.Sheets("Question 3"), 2, 4)
CopyCells(myWB.Sheets("Home"), myWB.Sheets("Question 2"), 3, 7)
'etc...

当然，这假定您始终希望目标比源高 2 行，并且源数据始终从第 6 行开始。如果其中任何一个是可变的，那么您可以将它们添加为参数，如好吧。

Answer 2

要修复您的代码，请替换此行中的 D 列：

Sheet3.Range("D" & i - 2).Value = NewData.Range("B" & i).Value

在您要复制到的下一列中：

Sheet3.Range("E" & i - 2).Value = NewData.Range("B" & i).Value

或者动态确定第一个空列：

lastCol = Sheet3.Cells(1, Sheet3.Columns.Count).xlEnd(xlToLeft).Column

那么复制行会变成：

Sheet3.Cells(i - 2, lastCol).Value = NewData.Range("B" & i).Value

---

.

下面的代码遍历所有工作表，如果找到名为“Home*”的工作表，它会将每个 Home 工作表中的 B 列复制到表的末尾

表格会根据需要自行调整大小（水平和垂直）

---

Option Explicit

Public Sub CopyColFromHome()
    Const BCOL = "B"
    Const FR = 6

    Dim wsQ As Worksheet:       Set wsQ = ThisWorkbook.Worksheets("Question 3")
    Dim tbl As ListObject:      Set tbl = wsQ.ListObjects("Table1") 'Update table name

    Dim ws As Worksheet, lr As Long, tblLc As Long, srcCol As Range, dstCol As Range

    tblLc = tbl.ListColumns.Count + 1               'First empty table column

    For Each ws In ThisWorkbook.Worksheets          'Iterate all sheets
        If LCase(Left(ws.Name, 4)) = "home" Then    'If sheet name starts with "home"

            lr = ws.Cells(ws.Rows.Count, BCOL).End(xlUp).Row    'Get last row in ws.colB

            If lr > FR Then     'If there are enough rows to copy from ws.colB

                wsQ.Cells(1, tblLc).Value2 = ws.Name    'Header of the new table column

                Set srcCol = ws.Range(ws.Cells(FR, BCOL), ws.Cells(lr, BCOL))
                Set dstCol = wsQ.Range(wsQ.Cells(FR - 2, tblLc), wsQ.Cells(lr - 2, tblLc))

                dstCol.Formula = srcCol.Formula         'Copy data to last column of table
                dstCol.ColumnWidth = dstCol.Offset(, -1).ColumnWidth    'Resize column

                tblLc = tblLc + 1   'Move to the next empty table column
            End If
        End If
    Next ws
End Sub

---

我的测试文件有 3 张主页表和一张“问题 3”：

工作表主页

工作表首页1

工作表首页2

工作表“问题 3”（附表格）

在循环的第一次迭代之后：

第三次迭代后（Home2 没有足够的行数）