根据您的需求，以下是改写后的内容： ```vb Sub CopyColumns() Dim c As Worksheet Windows("整理汇总").Activate For Each c In ThisWorkbook.Sheets ls2 = c.Range("a65535").End(3).Row ls = c.Range("c65535").End(3).Row c.Range("c1:c").Copy Workbooks("整理汇总").ActiveSheet.Range("a", ls2) Next End Sub ``` 在这个代码中，我们首先使用`ThisWorkbook.Sheets`来循环遍历原始数据中的每一张工作表。然后，我们通过`ls2`变量来获取目标工作表中的最后一行，并通过`ls`变量来获取源工作表中的最后一行。 接下来，我们使用`c.Range("c1:c").Copy`来复制源工作表中的所有列到目标工作表中，并将它们粘贴到目标工作表的从第一个单元格到最后一个单元格。 请注意，以上代码中并没有改变被选择的工作表，因此每次复制的都是被选择的那个工作表，并且会重复N次。 希望这个改写后的内容符合您的预期。如果还有其他问题需要解决，请随时告诉我。
Sub t1()Dim fdOpen As FileDialogDim fdPath$, fo, fd, f, xls, sh, dsh, r% Set fdOpen = Application.FileDialog(msoFileDialogFolderPicker) With fdOpen If .Show Then fdPath = .SelectedItems(1) End With Set fo = CreateObject(Scripting.FileSystemObject) Set fd = fo.GetFolder(fdPath) Set dsh = ThisWorkbook.Sheets.Add dsh.Name = 合并 & ThisWorkbook.Sheets.Count r = 1 dsh.Activate Application.ScreenUpdating = False For Each f In fd.Files If f.Name ThisWorkbook.Name And Not f.Name Like ~$* And (f.Name Like *.xls Or f.Name Like *.xlsx) Then Set xls = Workbooks.Open(f.Name) For Each sh In xls.Sheets sh.UsedRange.Copy dsh.Cells(r, 1) r = r + sh.UsedRange.Rows.Count Next xls.Close End If Next Application.ScreenUpdating = TrueEnd Sub =========================== Sub t2()Dim fdOpen As FileDialogDim fdPath$, f, xls, sh, dsh, r% Set fdOpen = Application.FileDialog(msoFileDialogFolderPicker) With fdOpen If .Show Then fdPath = .SelectedItems(1) End With Set dsh = ThisWorkbook.Sheets.Add dsh.Name = 合并 & ThisWorkbook.Sheets.Count r = 1 dsh.Activate Application.ScreenUpdating = False f = Dir(fdPath & \*.xls*) Do While f If f ThisWorkbook.Name And Not f Like ~$* Then Set xls = Workbooks.Open(f) For Each sh In xls.Sheets sh.UsedRange.Copy dsh.Cells(r, 1) r = r + sh.UsedRange.Rows.Count Next xls.Close End If f = Dir() Loop Application.ScreenUpdating = TrueEnd Sub
