將多個工作表中的表格和數組合併到一個合併表中

Question

我對VBA非常陌生並且掙扎不已！ 我試着搜索論壇，但無法找到任何足夠接近我的情況......

• 我已經30多張名爲001，002 ... 0nn
• 我想創建一個新的表標題「操作摘要」
• 我想這個表包含從表名稱爲每個表提供的信息編制「0nn」（或我試過限制的代碼是整數表名稱） - -
• 從我希望每個片將信息從列A複製到G，並將行9從最後一行輸入信息。
• 我還想在新的「行動摘要」表格頂部標題（A8：G8）。

SCREEN SHOT typical sheet 0nn format

已經持續有點瘋了，真的很感激一些簡單的幫助，最好有什麼每一位正在做的解釋所需要的代碼，所以我可以學。

我下面嘗試：

Function LastRow(sh As Worksheet) 
On Error Resume Next 
LastRow = sh.Cells.Find(What:="*", _ 
         After:=sh.Range("A1"), _ 
         lookat:=xlPart, _ 
         LookIn:=xlFormulas, _ 
         SearchOrder:=xlByRows, _ 
         SearchDirection:=xlPrevious, _ 
         MatchCase:=False).Row 
On Error GoTo 0 
End Function 

Function LastCol(sh As Worksheet) 
On Error Resume Next 
LastCol = sh.Cells.Find(What:="*", _ 
         After:=sh.Range("A1"), _ 
         lookat:=xlPart, _ 
         LookIn:=xlFormulas, _ 
         SearchOrder:=xlByColumns, _ 
         SearchDirection:=xlPrevious, _ 
         MatchCase:=False).Column 
On Error GoTo 0 
End Function 




Sub CopyRangeFromMultiWorksheets() 
Dim sh As Worksheet 
Dim DestSh As Worksheet 
Dim Last As Long 
Dim CopyRng As Range 

With Application 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

' Delete the summary sheet if it exists. 
Application.DisplayAlerts = False 
On Error Resume Next 
ActiveWorkbook.Worksheets("Actions Summary").Delete 
On Error GoTo 0 
Application.DisplayAlerts = True 

' Add a new summary worksheet. 
Set DestSh = ActiveWorkbook.Worksheets.Add 
DestSh.Name = "Actions Summary" 

' Loop through all worksheets and copy the data to the 
' summary worksheet. 
For Each sh In ActiveWorkbook.Worksheets 
    'If LCase(Left(sh.Name, 1)) = "0" Then 
    If IsNumeric(sh.Name) = True Then 
    Debug.Print (sh.Name) 
     ' Find the last row with data on the summary worksheet. 
     Last = LastRow(DestSh) 
     'LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row 
Debug.Print (Last) 
     ' Specify the range to place the data. 
     Set CopyRng = sh.Range("A9").CurrentRegion 
     Set CopyRng = Range(Cells(9, 1), Cells(Last, 7)) 

     ' Test to see whether there are enough rows in the summary 
     ' worksheet to copy all the data. 
     If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then 
      MsgBox "There are not enough rows in the " & _ 
       "summary worksheet to place the data." 
      GoTo ExitTheSub 
     End If 

     ' This statement copies values and formats from each 
     ' worksheet. 
     CopyRng.Copy 
     With DestSh.Cells(Last + 1, "A") 
      .PasteSpecial xlPasteValues 
      .PasteSpecial xlPasteFormats 
      Application.CutCopyMode = False 
     End With 

     ' Optional: This statement will copy the sheet 
     ' name in the H column. 
     ' DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name 


    End If 
Next 

'ExitTheSub: 

Application.Goto DestSh.Cells(1) 

' AutoFit the column width in the summary sheet. 
DestSh.Columns.AutoFit 

With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
End With 
End Sub 

Sub selectA1_and_insertRow() 
' 
' selectA1_and_insertRow Macro 

Worksheets("Actions Summary").Rows("1:1").Select 
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 
Columns("B:B").ColumnWidth = 36.43 
Rows("1:1").Select 
    'Range.Copy to other worksheets 
Worksheets("001").Range("A8:G8").Copy Worksheets("Actions Summary").Range("A1:G1") 

End Sub 

提前非常感謝。 湯姆

更新：爲什麼標題不交叉？

CODE：

這裏的新代碼：

子UpDate_List_v2（）

Dim wb As Workbook 
Dim ws As Worksheet 
Dim wsSum As Worksheet 
Dim rLastCell As Range 
Dim lCalc As XlCalculation 
Dim bHasHeaders As Boolean 


'Turn off calculation, events, and screenupdating 
'This allows the code to run faster and prevents "screen flickering" 
With Application 
    lCalc = .Calculation 
    .Calculation = xlCalculationManual 
    .EnableEvents = False 
    .ScreenUpdating = False 
End With 

Set wb = ActiveWorkbook 

'Check if Actions Summary sheet exists already or not 
On Error Resume Next 
Set wsSum = wb.Sheets("Actions summary") 
On Error GoTo 0 

If wsSum Is Nothing Then 
    'Does not exist, create it 
    Set wsSum = wb.Sheets.Add(Before:=wb.Sheets(1)) 
    wsSum.Name = "Actions summary" 
    bHasHeaders = False 
Else 
    'Already exists, clear previous data 
    wsSum.UsedRange.Offset(1).Clear 
    bHasHeaders = True 
End If 

'Loop through all sheets in the workbook 
For Each ws In wb.Sheets 
    'Only look for worksheets whose names are numbers (e.g. "001", "002", etc) 
    If IsNumeric(ws.Name) Then 
     'Check if the "Actions Summary" sheet already has headers 
     If bHasHeaders = False Then 
      'Does not have headers yet 
      With ws.Range("A8:M8") 
       'Check if this sheet has headers in A8:G8 
       If WorksheetFunction.CountBlank(.Cells) = 0 Then 
        'This sheet does have headers, copy them over 
        .Copy wsSum.Range("A1") 
        bHasHeaders = True 
       End If 
      End With 
     End If 

     'Find the last row of the sheet 
     Set rLastCell = ws.Cells.Find("*", ws.Range("A1"), SearchDirection:=xlPrevious) 
     If Not rLastCell Is Nothing Then 
      'Check if the last row is greater than the header row 
      If rLastCell.Row > 8 Then 
       'Last row is greater than the header row so there is data 
           'Check if the "Actions Summary" sheet has enough rows to hold the data 
           If wsSum.Cells(wsSum.Rows.Count, "A").End(xlUp).Row + rLastCell.Row - 8 > wsSum.Rows.Count Then 
            'Not enough rows, return error and exit the subroutine 
            MsgBox "There are not enough rows in the summary worksheet to place the data.", , "Data Overflow" 
            Exit Sub 
           Else 
        'Does have enough rows, copy the data - Values 
        ws.Range("A9:M" & rLastCell.Row).Copy 
        With wsSum.Cells(wsSum.Rows.Count, "A").End(xlUp).Offset(1) 
         .PasteSpecial xlPasteValues 
         .PasteSpecial xlPasteFormats 
        End With 
       End If 
      End If 
     End If 
    End If 
Next ws 

    'Sheets("Actions summary").Columns("H:L").EntireColumn.Delete  'Delete unwanted columns 
    'Sheets("Actions summary").Columns("H:L").Hidden = True    'Hide unwanted columns 
    Worksheets("Actions summary").Columns("H:j").Hidden = True 
    Worksheets("Actions summary").Columns("L").Hidden = True 
    Sheets("Actions summary").Columns("H").Style = "currency"   'Set to £ 

Application.CutCopyMode = False       'Remove the cut/copy border 
'wsSum.Range("A1").CurrentRegion.EntireColumn.AutoFit 'Autofit columns on the "Actions Summary" sheet 

'Turn calculation, events, and screenupdating back on 
With Application 
    .Calculation = lCalc 
    .EnableEvents = True 
    .ScreenUpdating = True 
End With 

末次

Answer 1

像這樣的東西應該爲你工作。爲了清晰起見，我已經評論了代碼。

Sub tgr() 

    Dim wb As Workbook 
    Dim ws As Worksheet 
    Dim wsSum As Worksheet 
    Dim rLastCell As Range 
    Dim lCalc As XlCalculation 
    Dim bHasHeaders As Boolean 

    'Turn off calculation, events, and screenupdating 
    'This allows the code to run faster and prevents "screen flickering" 
    With Application 
     lCalc = .Calculation 
     .Calculation = xlCalculationManual 
     .EnableEvents = False 
     .ScreenUpdating = False 
    End With 

    Set wb = ActiveWorkbook 

    'Check if Actions Summary sheet exists already or not 
    On Error Resume Next 
    Set wsSum = wb.Sheets("Actions summary") 
    On Error GoTo 0 

    If wsSum Is Nothing Then 
     'Does not exist, create it 
     Set wsSum = wb.Sheets.Add(Before:=wb.Sheets(1)) 
     wsSum.Name = "Actions summary" 
     bHasHeaders = False 
    Else 
     'Already exists, clear previous data 
     wsSum.UsedRange.Offset(1).Clear 
     bHasHeaders = True 
    End If 

    'Loop through all sheets in the workbook 
    For Each ws In wb.Sheets 
     'Only look for worksheets whose names are numbers (e.g. "001", "002", etc) 
     If IsNumeric(ws.Name) Then 
      'Check if the "Actions Summary" sheet already has headers 
      If bHasHeaders = False Then 
       'Does not have headers yet 
       With ws.Range("A8:G8") 
        'Check if this sheet has headers in A8:G8 
        If WorksheetFunction.CountBlank(.Cells) = 0 Then 
         'This sheet does have headers, copy them over 
         .Copy wsSum.Range("A1") 
         bHasHeaders = True 
        End If 
       End With 
      End If 

      'Find the last row of the sheet 
      Set rLastCell = ws.Cells.Find("*", ws.Range("A1"), SearchDirection:=xlPrevious) 
      If Not rLastCell Is Nothing Then 
       'Check if the last row is greater than the header row 
       If rLastCell.Row > 8 Then 
        'Last row is greater than the header row so there is data 
        'Check if the "Actions Summary" sheet has enough rows to hold the data 
        If wsSum.Cells(wsSum.Rows.Count, "A").End(xlUp).Row + rLastCell.Row - 8 > wsSum.Rows.Count Then 
         'Not enough rows, return error and exit the subroutine 
         MsgBox "There are not enough rows in the summary worksheet to place the data.", , "Data Overflow" 
         Exit Sub 
        Else 
         'Does have enough rows, copy the data - Values 
         ws.Range("A9:G" & rLastCell.Row).Copy 
         With wsSum.Cells(wsSum.Rows.Count, "A").End(xlUp).Offset(1) 
          .PasteSpecial xlPasteValues 
          .PasteSpecial xlPasteFormats 
         End With 
        End If 
       End If 
      End If 
     End If 
    Next ws 

    Application.CutCopyMode = False       'Remove the cut/copy border 
    wsSum.Range("A1").CurrentRegion.EntireColumn.AutoFit 'Autofit columns on the "Actions Summary" sheet 

    'Turn calculation, events, and screenupdating back on 
    With Application 
     .Calculation = lCalc 
     .EnableEvents = True 
     .ScreenUpdating = True 
    End With 

End Sub