Question

vba复制excel工作簿中所有表的某一列到另一个工作簿中

工作簿“原始数据”中有数量未知，工作表名为1到N的sheet
要将每个sheet的C列依次全部复制到工作簿“整理汇总”sheet1的A列中
自己胡乱编的，每次都只能复制“原始数据”的第一个工作表的C列N遍
Sub xxxx()
Dim c As Worksheet
For Each c In Worksheets
ls = c.Range("c65535").End(3).Row
Range("c1:c" & ls).Select
Selection.Copy
Windows("整理汇总").Activate
ls2 = Range("a65535").End(3).Row
Range("a" & ls2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("原始数据").Activate
Next
End Sub
求指导

Answer 1

Range("c1:c" & ls).Select 这一句，应改为c.Range("c1:c" & ls).Select,前面再加一句，c.select

你循环了 原始数据 的每一个工作表，但是没有改变被选择的工作表，所以每次复制的都是被选择的那个工作表，就会被复制N遍了。

顺便说一下，你这样复制效率很低，因为要不断的切换激活的窗口，改变被选择的工作表，阳光上的桥的答案是效率很高的，不用切换激活的窗口，改变被选择的工作表，但是他的答案不符合你的要求，不是全部复制到A列，是复制到很多列了。给你改进了一下，如下：

Sub xxxx()
    Dim c As Worksheet
    Windows("整理汇总").Activate
    For Each c In  Workbooks("原始数据").Worksheets
        ls2 = Workbooks("整理汇总").ActiveSheet.Range("a65535").End(3).Row
        ls = c.Range("c65535").End(3).Row
        c.Range("c1:c" & ls).Copy Workbooks("整理汇总").ActiveSheet.Range("a" & ls2)
    Next
End Sub

Answer 2

Option Explicit

Sub xxxx()
    Dim c As Worksheet, j As Long
    j = 1
    For Each c In Workbooks("原始数据").Sheets
        c.Rows("C").Copy        Workbooks("整理汇总").Sheets(1).Rows (j)
        j = j + 1
    Next
End Sub

这个代码是不是很简单，能看懂吧，把 原始数据 每个表的C列复制到 整理汇总 第一个表的1、2、3……列