从每个Excel选项卡中提取表格数据，并将数据粘贴到一张纸上

我有一个有75个选项卡的excel电子表格 – 每个选项卡都以相同的方式用两列文字格式化。 我希望所有这些数据都位于单个页面上，但是我不知道如何以编程方式从每个选项卡中提取表格并将其粘贴到单个选项卡上。

有没有办法在Excel中做到这一点？

---

好的，下面是我试过的代码：

Sub Macro5() Range("A1:B30").Select Selection.Copy Sheets("Table 1").Select Selection.End(xlDown).Select Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _ , SkipBlanks:=False, Transpose:=False End Sub 

所有选项卡的格式都相同，数据来自A1：B30的所有单元格。 我在想，Selection.End命令将转到下一个可用的打开的单元格，并粘贴后续选项卡中的数据。

截至目前，我需要去每个选项卡，并单独运行这个macros，除了它不工作，因为它说粘贴的数据不是现有的数据相同的types/格式。

有任何想法吗？

---

编码尝试＃2-成功！

  Sub Macro5() Dim ws As Worksheet For Each ws In ActiveWorkbook.Worksheets ws.activate Range("A1:B30").Select Selection.Copy Sheets("Table 1").Select Selection.End(xlDown).Select Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _ , SkipBlanks:=False, Transpose:=False On Error Resume Next 'Will continue if an error results Next ws End Sub 

那么，我不愿意承认，我很高兴你没有把勺子喂给我。 先生，好的。

---

编码尝试＃3-避免select

 Sub Macro5() Dim ws As Worksheet For Each ws In ActiveWorkbook.Worksheets Set Rng = ws.Range("A1:B30") Rng.Copy Dim ws1 As Worksheet Set ws1 = Worksheets("Table 1") ws1.Select Selection.End(xlDown).Select Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _ , SkipBlanks:=False, Transpose:=False On Error Resume Next 'Will continue if an error results Next ws End Sub 

不完全正确 – 它仍然有效，但我不知道如何避免使用“select”，当我到达第一个工作簿。 有没有办法引用最接近的细胞没有内容？ 我知道'结束'键可以做到这一点，但有没有一种非select的方式？

Answer 1

看到这个代码。

1. 我修改了你的代码，使它不使用。select或.Activate 。
2. 我已经评论了代码，所以你不应该有理解它的问题。 🙂
3. 该代码不会使用On Error Resume Next 。 除非有必要，否则应该避免这种情况。 改用适当的error handling。 考虑On Error Resume Next作为告诉你的应用程序简单地closures。 🙂

这是一个基本的error handling的例子

 Sub Sample() On Error GoTo Whoa ' '~~> Rest of Code ' Exit Sub Whoa: MsgBox Err.Description End Sub 

所以这就是你的最终代码的样子。 它避免了使用.Select或.Activate 。 它也避免使用Selection并find需要复制的确切范围，以及确切范围需要复制的地方。 它也做适当的error handling。

 Option Explicit Sub Sample() Dim wsInput As Worksheet, wsOutput As Worksheet Dim rng As Range Dim LRowO As Long, LRowI As Long On Error GoTo Whoa '~~> Set your Output Sheet Set wsOutput = ThisWorkbook.Sheets("Table 1") '~~> Loop through all sheets For Each wsInput In ThisWorkbook.Worksheets '~~> Ensure that we ignore the output sheet If wsInput.Name <> wsOutput.Name Then '~~> Working with the input sheet With wsInput '~~> Get the last row of input sheet LRowI = .Range("A" & .Rows.Count).End(xlUp).Row '~~> Set your range for copying Set rng = .Range("A1:B" & LRowI) '~~> Copy your range rng.Copy '~~> Pasting data in the output sheet With wsOutput '~~> Get the next available row in output sheet for pasting LRowO = .Range("A" & .Rows.Count).End(xlUp).Row + 1 '~~> Finally paste .Range("A" & LRowO).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=False End With End With End If Next wsInput Exit Sub Whoa: MsgBox Err.Description End Sub