Question

我对VBA很新并且很挣扎！我试过搜索论坛，但找不到足够接近我的情况......

我有30多张标题为001,002 ... 0nn
我想创建一个新的工作表标题＆＃39;操作摘要＆＃39;
我希望此工作表包含来自每张工作表的已编译信息，其中包含工作表名称＆＃39; 0nn＆＃39; （或者我尝试将代码限制为整数的工作表名称） - -
从每张工作表中我想要将信息从A列复制到G，将第9行复制到最后一行，其中包含信息。
我还希望标题（A8：G8）位于新动作摘要＆＃39;的顶部。片材。

SCREEN SHOT典型的表格0nn格式

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：

这是新代码：

Sub 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

End Sub

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

将多个工作表中的表和数组合并到一个统一表中

SCREEN SHOT典型的表格0nn格式

1 个答案: