Question

我正在运行以下代码，并且没有For，我就错过了一些东西。我想保留最先出现的四张excel表 1. Sheet1 2.发票合并 3. Merge_Excel 4.合并

其余的工作表已导入到Excel中，需要合并到工作表名称＆＃34; Consolidated＆＃34;并在合并后删除。我尝试包含我不想删除的工作表名称，如果在执行时出错，则添加结尾。

代码1：（此代码检查一系列sheet1中的发票，发票范围在＆＃34; invoicesconsolidated＆＃34;通过过滤K列并将过滤后的项目复制到名为sheet的新工作表中发票号码

Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim Last As Long
Dim sht As String
Dim shtb As String


 sht = "InvoicesConsolidated"
 shtb = "Sheet1"

 'change filter column in the following code
 Last = Sheets(sht).Cells(Rows.Count, "K").End(xlUp).Row
 Set rng = Sheets(sht).Range("A1:K" & Last)

 'Sheets(shtb).Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy,   CopyToRange:=Range("AA1"), Unique:=True

  For Each x In shtb.Range([A2], Cells(Rows.Count, "A").End(xlUp))
  With rng
 .AutoFilter
 .AutoFilter Field:=11, Criteria1:=x.Value
 .SpecialCells(xlCellTypeVisible).Copy

 Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
 ActiveSheet.Paste
 End With
 Next x

 'Turn off filter
 Sheets(sht).AutoFilterMode = False

 With Application
 .CutCopyMode = False
 .ScreenUpdating = True
 End With

 Sheets("InvoicesConsolidated").Select

 End Sub

代码2：（此代码实际上是将匹配发票后创建的工作表合并到一张工作表中并删除其余工作表。

Private Sub CommandButton2_Click()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long

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

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

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

' Fill in the start row.
StartRow = 1

' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name Then
        If sh.Name <> "Merge_Excel" Then
            If sh.Name <> "Sheet1" Then
                If sh.Name <> "InvoicesConsolidated" Then


        ' Find the last row with data on the summary
        ' and source worksheets.
        Last = LastRow(DestSh)
        shLast = LastRow(sh)

        ' If source worksheet is not empty and if the last
        ' row >= StartRow, copy the range.
        If shLast > 0 And shLast >= StartRow Then
            'Set the range that you want to copy
            Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

           ' 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
            End If
            End If


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

        End If
        End If
        End If


    Application.DisplayAlerts = False
    If sh.Name <> "Merge_Excel" Then
    If sh.Name <> "Sheet1" Then
    If sh.Name <> "InvoicesConsolidated" Then
        On Error Resume Next
        If sh.Name <> "Consolidated" Then ActiveWorkbook.Worksheets(sh.Name).Delete
        On Error GoTo 0
        Application.DisplayAlerts = True
    End If


Next

ExitTheSub:



' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit
 'ThisWorkbook.Sheets("Consolidated").Range("A1:K50000").Sort Key1:=ThisWorkbook.Sheets("Consolidated").Range("A2"), Order1:=xlDescending, Header:=xlYes



ReadOutlineCells
With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
MsgBox ("Consolidated")
End Sub


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

Function ReadOutlineCells()
Dim rng As Range
Set rng = ActiveWorkbook.Worksheets("Consolidated").Range("A1:K10000")
With rng.Borders
.LineStyle = xlContinuous
.Color = vbBlack
End With
End Function'

Answer 1

如果你更正了缩进，你会发现问题要快得多。我在下面尝试了它，这导致了一些添加的行和一些删除的行。我不确定这是否是你所寻求的逻辑，但这里的信息是让你的缩进始终保持良好状态 - 尤其是在编写代码时。

Private Sub CommandButton2_Click() Dim sh As Worksheet Dim DestSh As Worksheet Dim Last As Long Dim shLast As Long Dim CopyRng As Range Dim StartRow As Long With Application .ScreenUpdating = False .EnableEvents = False End With ' Delete the summary sheet if it exists. Application.DisplayAlerts = False On Error Resume Next ActiveWorkbook.Worksheets("Consolidated").Delete On Error GoTo 0 Application.DisplayAlerts = False ' Add a new summary worksheet. Set DestSh = ActiveWorkbook.Worksheets.Add DestSh.Name = "Consolidated" ' Fill in the start row. StartRow = 1 ' Loop through all worksheets and copy the data to the ' summary worksheet. For Each sh In ActiveWorkbook.Worksheets If sh.Name <> DestSh.Name Then If sh.Name <> "Merge_Excel" Then If sh.Name <> "Sheet1" Then If sh.Name <> "InvoicesConsolidated" Then ' Find the last row with data on the summary ' and source worksheets. Last = LastRow(DestSh) shLast = LastRow(sh) ' If source worksheet is not empty and if the last ' row >= StartRow, copy the range. If shLast > 0 And shLast >= StartRow Then 'Set the range that you want to copy Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast)) ' 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 End If End If End If StartRow = 1 ' This statement copies values and formats. CopyRng.Copy With DestSh.Cells(Last + 1, "A") .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats Application.CutCopyMode = False End With End If End If Application.DisplayAlerts = False If sh.Name <> "Merge_Excel" Then If sh.Name <> "Sheet1" Then If sh.Name <> "InvoicesConsolidated" Then On Error Resume Next If sh.Name <> "Consolidated" Then ActiveWorkbook.Worksheets(sh.Name).Delete On Error GoTo 0 Application.DisplayAlerts = True End If End If End If Next ExitTheSub: ' AutoFit the column width in the summary sheet. DestSh.Columns.AutoFit 'ThisWorkbook.Sheets("Consolidated").Range("A1:K50000").Sort Key1:=ThisWorkbook.Sheets("Consolidated").Range("A2"), Order1:=xlDescending, Header:=xlYes ReadOutlineCells With Application .ScreenUpdating = True .EnableEvents = True End With MsgBox ("Consolidated") End Sub

Answer 2

以下部分中If <> ...的多个条件：

If sh.Name <> DestSh.Name Then
        If sh.Name <> "Merge_Excel" Then
            If sh.Name <> "Sheet1" Then
                If sh.Name <> "InvoicesConsolidated" Then

可以使用以下代码中的Select Case轻松替换：

Select Case sh.Name

    Case DestSh.Name, "Merge_Excel", "Sheet1", "InvoicesConsolidated"
        ' do nothing

    Case Else
        ' this is the scenario you are describing in your code
        ' rest of your code goes here

End Select

运行宏时出错 - 下一步没有For

2 个答案: