Question

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

您可能会问，为什么不手动复制/粘贴表格中的数据？我有多个选项卡，我将创建多个宏 - 每个选项卡一个。理想情况下，我会根据粘贴在＆lt; 主页＆＃39;中的单个列中的信息来运行宏。选项卡，它将作为新列粘贴到其要访问的选项卡中的表中。

<a class="popup_link" href="https://stackoverflow.com">Click me!</a>

Answer 1

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

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

简单的做法是将此行更改为Set Sheet3 = Sheets("Question 3")
如此类似Set otherSheet = Sheets("Question 3")

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

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

下面的代码通过所有工作表迭代，如果找到名为＆＃34; Home *＆＃34;它会将每个主页的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张主页和1张＆＃34;问题3＆＃34;：

Sheet Home

Sheet Home1

Sheet Home2

表＆＃34;问题3＆＃34; （附表）

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

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

循环以将一个工作表中的列复制到另一个工作表中的表

2 个答案: