如何使用pastespecial结束（xlUp）

我目前有一个问题，从一个工作表获取数据粘贴到另一个工作表，我试图将多个文件（相同的标题，不同数量的行）合并到一个包含所有行的主表。 目前我正在通过打开所有文件，拉入我想要的选项卡，复制并粘贴数据，然后删除选项卡。 是的，我相信有一个更简单的方法，但我对VBA很新，并且正在学习。到目前为止，我还有：

Sub ConsolidateSheets() ' open each file in folder Dim Folder As String Dim Files As String Folder = "C:\Users\212411103\Documents\Risk Project Tracker\Risk Project Tracker Monthly\Monthly Data" Files = Dir(Folder & "\*.xls") Do While Files <> "" Workbooks.Open Filename:=Folder & "\" & Files Files = Dir Loop ' pull in Risk Project Tracker tab from each file to new workbook Dim wkb As Workbook Dim sWksName As String sWksName = "Risk Project Tracker" For Each wkb In Workbooks If wkb.Name <> ThisWorkbook.Name Then wkb.Worksheets(sWksName).Copy _ Before:=ThisWorkbook.Sheets(1) End If Next Set wkb = Nothing Dim J As Integer ' add new sheet for combined data On Error Resume Next Sheets(1).Select Worksheets.Add Sheets(1).Name = "New Month" ' paste headers from first two rows into new sheet "New Month" Sheets(2).Select Range("A1:AH2").Select Selection.Copy Sheets("New Month").Select Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False ActiveSheet.Paste Range("A1").Select ' work through sheets For J = 2 To Sheets.Count ' from sheet 2 to last sheet Sheets(J).Activate ' make the sheet active Rows("1:2").Select Selection.Delete Shift:=xlUp Range("A1:AH500").Select Selection.Copy Sheets("New Month").Select Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Range("A1").Select Next ' Delete tabs that are no longer needed ie the tabs from the 17 files ' For Each ws in Sheets ' Application.DisplayAlerts=False ' If ws.Name <> "New Month" Then ws.delete ' Next ' Application.DisplayAlerts=True End Sub 

Answer 1

看起来，指定Range.PasteSpecial方法的主要原因是每个选项卡的列宽度的结转。 也许通过A：AH循环一次，设置列宽应该足够了。

 Sub ConsolidateSheets2() Dim fldr As String, fn As String, sWksName As String, sNewWksName As String Dim ws As Worksheet, wkb As Workbook On Error GoTo bm_Safe_Exit Application.ScreenUpdating = False Application.EnableEvents = False sWksName = "Risk Project Tracker" fldr = "C:\Users\212411103\Documents\Risk Project Tracker\Risk Project Tracker Monthly\Monthly Data" fn = Dir(fldr & "\*.xls") sNewWksName = "New Month" With ThisWorkbook Do While fn <> "" Set wkb = Workbooks.Open(Filename:=fldr & Chr(92) & fn) If IsObject(wkb.Worksheets(sWksName)) Then wkb.Worksheets(sWksName).Copy _ Before:=ThisWorkbook.Sheets(1 - CBool(Sheets(1).Name = sNewWksName)) On Error GoTo bm_Need_New_Month_ws With .Worksheets(sNewWksName) On Error GoTo bm_Safe_Exit .Parent.Sheets(2).Range("A3:AH502").Copy _ Destination:=.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End With End If wkb.Close False fn = Dir Loop Application.DisplayAlerts = False Do While Sheet.Count > 1: Sheets(2).Delete: Loop End With GoTo bm_Safe_Exit bm_Need_New_Month_ws: If Err.Number = 9 Then With ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Sheets(1)) .Name = sNewWksName .Move Before:=Sheets(1) .Parent.Sheets(2).Range("A1:AH2").Copy _ Destination:=.Range("A1") For c = .Columns("AH:AH").Column To 1 Step -1 .Columns(c).ColumnWidth = _ .Parent.Sheets(2).Columns(c).ColumnWidth Next c End With Resume End If bm_Safe_Exit: Application.ScreenUpdating = True Application.EnableEvents = True End Sub