Отрывки кода, которые работают независимо, больше не работают при сшивании - VBA Userform - PullRequest
Новая
       48

Отрывки кода, которые работают независимо, больше не работают при сшивании - VBA Userform

1 голос
/ 05 февраля 2020

Мне было поручено создать скрипт vba, который имеет пользовательскую форму с текстовым полем, кнопкой обзора и кнопкой преобразования. Он принимает два разных файла .csv, проверяет, существует ли определенный столбец, выполняет ли он один набор форматирования и удаляет столбец на основе имен заголовков. Если нет, выполняет другой набор форматирования на основе имен заголовков. После этого он распечатывается на принтере по умолчанию.

Я сшил много разных решений от разных талантливых людей, а также свой собственный код. Каждый из них работал отлично, когда тестировал по одному. Как только я сложил их все вместе, я наткнулся на загадку.

Я получил ошибку

"Ошибка компиляции: иначе без If"

Я искал и нашел множество потоков, в которых люди указывали, что если вы добавляете какое-либо утверждение после той же строки, оно закрывает оператор if. Я проверил свой код и не смог найти ни одного такого экземпляра.

Я уже несколько дней смотрю на один и тот же кусок кода и уже не приблизился к решению. Я надеялся, что свободный sh набор желающих глаз может заметить область, на которой я обманываю.

Любые и все предложения или рекомендации приветствуются!

Спасибо всем заранее. 

'Shows Open File Dialog Box.
Private Sub CommandButton1_Click()
    ' Private Sub openDialog()
    Dim fd          As Office.FileDialog

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    With fd

        .AllowMultiSelect = FALSE

        ' Set the title of the dialog box.
        .title = "Please Select the file."

        ' Clear out the current filters, and add our own.
        .Filters.Clear
        .Filters.Add "Report Export", "*.csv"
        .Filters.Add "All Files", "*.*"

        ' Show the dialog box. If the .Show method returns True, the
        ' user picked at least one file. If the .Show method returns
        ' False, the user clicked Cancel.
        If .Show = TRUE Then
            TextBox1 = .SelectedItems(1)

        End If
    End With
    ' End Sub
End Sub
'****************************************

Private Sub Convert_Click()
    If TextBox1.Value = "" Then
        MsgBox "Please Select a file first!"
    Else
        Workbooks.Open Filename:=TextBox1ActiveSheet.Name = "REPORT"

        'DELETES BLANK ROWS
        Dim iCounter As Long
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = FALSE
            For iCounter = Selection.Rows.Count To 1 Step -1
                If WorksheetFunction.CountA(Selection.Rows(iCounter)) = 0 Then
                    Selection.Rows(iCounter).EntireRow.Delete
                End If
            Next iCounter
            .Calculation = xlCalculationAutomatic
            .ScreenUpdating = TRUE
        End With
        '************************

        Dim rngToSearch As Range
        Dim WhatToFind As Variant
        Dim iCtr    As Long

        Set rngToSearch = ThisWorkbook.Worksheets("REPORT").Range("A1:Z1")

        WhatToFind = Array("Card Type")        'add all Column header that you want to check

        With rngToSearch
            For iCtr = LBound(WhatToFind) To UBound(WhatToFind)
                If WorksheetFunction.CountIf(rngToSearch, WhatToFind(iCtr)) > 0 Then        ' Check if column is preset or not
                ' CODE if column exists
                '********START CC********
                'DELETES UNUSED COLUMNS
                Dim currentColumn As Integer
                Dim columnHeading As String
                ActiveSheet.Columns("Z").Delete
                For currentColumn = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
                    columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value

                    'CHECK WHETHER TO KEEP THE COLUMN
                    Select Case columnHeading
                        Case "User", "Effective Date", "Account", "Customer Name", "Email", "Auth Amount", "Auth Status", "Auth Code"
                            'Do nothing
                        Case Else
                            'Delete if the cell doesn't contain "Homer"
                            If InStr(1, _
                            ActiveSheet.UsedRange.Cells(1, currentColumn).Value, _
                            "Homer", vbBinaryCompare) = 0 Then

                            ActiveSheet.Columns(currentColumn).Delete

                        End If
                End Select
            Next

            'Format Sheets
            '****Column User****
            Dim colUser As Long
            Dim ColumnUser As Long
            'Get Column User
            colUser = WorksheetFunction.Match("User", Rows("1:1"), 0)
            'Convert To Column Letter
            ColumnUser = Split(Cells(1, colUser).Address, "$")(1)

            '****Column EffectiveDate****
            Dim colEffectiveDate As Long
            Dim ColumnEffectiveDate As Long
            'Get Column EffectiveDate
            colEffectiveDate = WorksheetFunction.Match("Effective Date", Rows("1:1"), 0)
            'Convert To Column Letter
            ColumnEffectiveDate = Split(Cells(1, colEffectiveDate).Address, "$")(1)

            '****Column Account****
            Dim colAccount As Long
            Dim ColumnAccount As Long
            'Get Column Account
            colAccount = WorksheetFunction.Match("Account", Rows("1:1"), 0)
            'Convert To Column Letter
            ColumnAccount = Split(Cells(1, colAccount).Address, "$")(1)

            '****Column CustName****
            Dim colCustName As Long
            Dim ColumnCustName As Long
            'Get Column Account
            colCustName = WorksheetFunction.Match("Customer Name", Rows("1:1"), 0)
            'Convert To Column Letter
            ColumnCustName = Split(Cells(1, colCustName).Address, "$")(1)

            '****Column CustEmail****
            Dim colCustEmail As Long
            Dim ColumnCustEmail As Long
            'Get Column Account
            colCustEmail = WorksheetFunction.Match("Email", Rows("1:1"), 0)
            'Convert To Column Letter
            ColumnCustEmail = Split(Cells(1, colCustEmail).Address, "$")(1)

            '****Column Amount****
            Dim colAmount As Long
            Dim ColumnAmount As Long
            'Get Column Account
            colAmount = WorksheetFunction.Match("Auth Amount", Rows("1:1"), 0)
            'Convert To Column Letter
            ColumnAmount = Split(Cells(1, colAmount).Address, "$")(1)

            '****Column AuthStatus****
            Dim colAuthStatus As Long
            Dim ColumnAuthStatus As Long
            'Get Column Account
            colAuthStatus = WorksheetFunction.Match("Auth Status", Rows("1:1"), 0)
            'Convert To Column Letter
            ColumnAuthStatus = Split(Cells(1, colAuthStatus).Address, "$")(1)

            '****Column AuthCode****
            Dim colAuthCode As Long
            Dim ColumnAuthCode As Long
            'Get Column Account
            colAuthCode = WorksheetFunction.Match("Auth Code", Rows("1:1"), 0)
            'Convert To Column Letter
            ColumnAuthCode = Split(Cells(1, colAuthCode).Address, "$")(1)

            ' Sets Column Widths
            Worksheets("REPORT").Range(ColumnUser & ":" & ColumnAuthCode).EntireColumn.AutoFit
            Worksheets("REPORT").Range(ColumnCustName & ":" & ColumnCustEmail).ColumnWidth = 30

            ' Turns Word Wrap ON
            Worksheets("REPORT").Range(ColumnUser & ":" & ColumnAuthCode).WrapText = TRUE
            Worksheets("REPORT").Range(ColumnUser & ":" & ColumnAuthCode).VerticalAlignment = xlVAlignTop
            Worksheets("REPORT").Range(ColumnUser & ":" & ColumnAuthCode).HorizontalAlignment = xlHAlignLeft
            Worksheets("REPORT").Range("A1").EntireRow.Font.Bold = TRUE
            Worksheets("REPORT").Range("A1").EntireRow.Font.Size = 12

            ' Set Page Settings
            ActiveSheet.Range(ColumnUser & ":" & ColumnAuthCode).CurrentRegion
            With ActiveSheet.PageSetup

                .Orientation = xlLandscape
                .Zoom = FALSE
                .FitToPagesWide = 1
                .FitToPagesTall = FALSE
                .LeftMargin = Application.InchesToPoints(0.25)
                .RightMargin = Application.InchesToPoints(0.25)
                .BottomMargin = Application.InchesToPoints(0.25)
                .TopMargin = Application.InchesToPoints(0.25)
            End With

            'Finds the last non-blank cell in a single row or column
            Dim lRow As Long

            'Find the last non-blank cell
            lRow = Cells.Find(What:="*", _
            After:=Range("A1"), _
            LookAt:=xlPart, _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False).Row

            ' Row color change
            Dim i   As Integer
            For i = 2 To lRow
                If i Mod 2 = 0 Then
                    ActiveSheet.Range(ActiveSheet.Cells(i, 1), ActiveSheet.Cells(i, lCol)).Select
                    With Selection.Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                        .ThemeColor = xlThemeColorAccent6
                        .TintAndShade = 0.799981688894314
                        .PatternTintAndShade = 0
                    End With
                End If
            Next i

            ' Add Totals
            Dim LastRow As Long
            Dim bottomRow As Long

            LastRow = Cells.Find(What:="*", _
                      After:=Range("A1"), _
                      LookAt:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row

            If LastRow >= 2 Then
                Cells(LastRow + 2, ColumnAmount).Formula = "=SUM(" & ColumnAmount & "2" & ":" & ColumnAmount & LastRow & ")"
            ElseIf LastRow < 2 Then
                Cells(LastRow + 2, ColumnAmount).Value = Range(ColumnAmount & "2").Value
            End If

            Cells(lRow + 2, ColumnCustEmail).Value = "Total:"

            bottomRow = lRow + 2
            Let Copyrange = ColumnCustEmail & bottomRow & ":" & ColumnAmount & bottomRow
            Range(Copyrange).BorderAround _
                                          ColorIndex:=3, Weight:=xlThick

            Range(Copyrange).Font.Bold = TRUE
            Range(Copyrange).Font.Size = 14

            ' Add Auto Print HERE
            Worksheets("REPORT").PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False

            Application.DisplayAlerts = FALSE
            Application.Quit
        End If
    End Sub
    '*********End of CCs**********

Else
    ' CODE if column is Not Found
    '********CHECKS********

    'DELETES UNUSED COLUMNS
    Dim currentColumn As Integer
    Dim columnHeading As String
    ActiveSheet.Columns("Z").Delete
    For currentColumn = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
        columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value

        'CHECK WHETHER TO KEEP THE COLUMN
        Select Case columnHeading
            Case "User", "Payment Date", "Account", "Customer Name", "Customer Email", "Amount", "Comment"
                'Do nothing
            Case Else
                'Delete if the cell doesn't contain "Homer"
                If InStr(1, _
                ActiveSheet.UsedRange.Cells(1, currentColumn).Value, _
                "Homer", vbBinaryCompare) = 0 Then

                ActiveSheet.Columns(currentColumn).Delete

            End If
    End Select
Next

'Format Sheets
'****Column User****
Dim colUser         As Long
Dim ColumnUser      As Long
'Get Column User
colUser = WorksheetFunction.Match("User", Rows("1:1"), 0)
'Convert To Column Letter
ColumnUser = Split(Cells(1, colUser).Address, "$")(1)

'****Column PaymentDate****
Dim colPaymentDate  As Long
Dim ColumnPaymentDate As Long
'Get Column PaymentDate
colPaymentDate = WorksheetFunction.Match("Payment Date", Rows("1:1"), 0)
'Convert To Column Letter
ColumnPaymentDate = Split(Cells(1, colPaymentDate).Address, "$")(1)

'****Column Account****
Dim colAccount      As Long
Dim ColumnAccount   As Long
'Get Column Account
colAccount = WorksheetFunction.Match("Account", Rows("1:1"), 0)
'Convert To Column Letter
ColumnAccount = Split(Cells(1, colAccount).Address, "$")(1)

'****Column CustName****
Dim colCustName     As Long
Dim ColumnCustName  As Long
'Get Column Account
colCustName = WorksheetFunction.Match("Customer Name", Rows("1:1"), 0)
'Convert To Column Letter
ColumnCustName = Split(Cells(1, colCustName).Address, "$")(1)

'****Column CustEmail****
Dim colCustEmail    As Long
Dim ColumnCustEmail As Long
'Get Column Account
colCustEmail = WorksheetFunction.Match("Customer Email", Rows("1:1"), 0)
'Convert To Column Letter
ColumnCustEmail = Split(Cells(1, colCustEmail).Address, "$")(1)

'****Column Amount****
Dim colAmount       As Long
Dim ColumnAmount    As Long
'Get Column Account
colAmount = WorksheetFunction.Match("Amount", Rows("1:1"), 0)
'Convert To Column Letter
ColumnAmount = Split(Cells(1, colAmount).Address, "$")(1)

'****Column Comment****
Dim colComment      As Long
Dim ColumnComment   As Long
'Get Column Account
colComment = WorksheetFunction.Match("Comment", Rows("1:1"), 0)
'Convert To Column Letter
ColumnComment = Split(Cells(1, colComment).Address, "$")(1)

' Sets Column Widths
Worksheets("REPORT").Range(ColumnUser & ":" & ColumnComment).EntireColumn.AutoFit
Worksheets("REPORT").Range(ColumnCustName & ":" & ColumnCustEmail).ColumnWidth = 30
Worksheets("REPORT").Range(ColumnComment & ":" & ColumnComment).ColumnWidth = 50

' Turns Word Wrap ON
Worksheets("REPORT").Range(ColumnUser & ":" & ColumnComment).WrapText = TRUE
Worksheets("REPORT").Range(ColumnUser & ":" & ColumnComment).VerticalAlignment = xlVAlignTop
Worksheets("REPORT").Range(ColumnUser & ":" & ColumnComment).HorizontalAlignment = xlHAlignLeft
Worksheets("REPORT").Range("A1").EntireRow.Font.Bold = TRUE
Worksheets("REPORT").Range("A1").EntireRow.Font.Size = 12

' Set Page Settings
ActiveSheet.Range(ColumnUser & ":" & ColumnComment).CurrentRegion
With ActiveSheet.PageSetup

    .Orientation = xlLandscape
    .Zoom = FALSE
    .FitToPagesWide = 1
    .FitToPagesTall = FALSE
    .LeftMargin = Application.InchesToPoints(0.25)
    .RightMargin = Application.InchesToPoints(0.25)
    .BottomMargin = Application.InchesToPoints(0.25)
    .TopMargin = Application.InchesToPoints(0.25)
End With

'Finds the last non-blank cell in a single row or column
Dim lRow            As Long

'Find the last non-blank cell
lRow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row

' Row color change
Dim i               As Integer
For i = 2 To lRow
    If i Mod 2 = 0 Then
        ActiveSheet.Range(ActiveSheet.Cells(i, 1), ActiveSheet.Cells(i, lCol)).Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent6
            .TintAndShade = 0.799981688894314
            .PatternTintAndShade = 0
        End With
    End If
Next i

' Add Totals
Dim LastRow         As Long
Dim bottomRow       As Long

LastRow = Cells.Find(What:="*", _
          After:=Range("A1"), _
          LookAt:=xlPart, _
          LookIn:=xlFormulas, _
          SearchOrder:=xlByRows, _
          SearchDirection:=xlPrevious, _
          MatchCase:=False).Row

If LastRow >= 2 Then
    Cells(LastRow + 2, ColumnAmount).Formula = "=SUM(" & ColumnAmount & "2" & ":" & ColumnAmount & LastRow & ")"
ElseIf LastRow < 2 Then
    Cells(LastRow + 2, ColumnAmount).Value = Range(ColumnAmount & "2").Value
End If

Cells(lRow + 2, ColumnCustEmail).Value = "Total:"

bottomRow = lRow + 2
Let Copyrange = ColumnCustEmail & bottomRow & ":" & ColumnAmount & bottomRow
Range(Copyrange).BorderAround _
                              ColorIndex:=3, Weight:=xlThick

Range(Copyrange).Font.Bold = TRUE
Range(Copyrange).Font.Size = 14

' Add Auto Print HERE
Worksheets("REPORT").PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False

Application.DisplayAlerts = FALSE
Application.Quit
End If
End Sub
'********END CHECKS*********

End If
Next
End With

End Sub

РЕДАКТИРОВАТЬ:

Изменения, которые были сделаны:

  • Свернул и сжал мой код, чтобы удалить ненужные пустые Строки.
  • Tab корректно отступил в коде
  • Удалены закрывающие теги, которые были ошибочно оставлены.
  • Добавлены закрывающие теги там, где их не было.
  • Добавлен определения переменных
  • Исправленные ссылки на объекты.
  • МНОГИ ОТЛАДКИ.

Спасибо всем за помощь. Я изучил некоторые лучшие практики и смог все запустить и запустить!

Ответы [ 2 ]

1 голос
/ 05 февраля 2020

Во-первых, всегда указывайте Option Explicit в верхней части кода. Если это было сделано, то вы увидите ряд переменных, которые не были объявлены. Кроме того, вы бы видели множество дублированных переменных ..

В частности, в отношении вашего сообщения об ошибке, это связано с тем, что у вас есть мошенник Else И также у вас есть 2 х жулик End If И вам не хватает End If. Я прокомментировал это в вашем коде. Удалите их оба, и ваш код будет работать .

Также вы использовали End Sub несколько раз в процедуре. Здесь я сделаю предположение, что на самом деле вы хотите EXIT сабвуфера, таким образом заменяя Exit Sub

Я обычно не вижу код и переписываю, но ваш код был грязным , не с отступом правильно, и это, без сомнения, помогло привести к проблемам, которые у вас возникли. Аккуратный код легко читать, легко писать. Однако я повторяю вышеизложенное о том, что более мелкие процедуры являются ключом к хорошим навыкам написания кода. 

'Shows Open File Dialog Box.
Private Sub CommandButton1_Click()
    ' Private Sub openDialog()
    Dim fd          As Office.FileDialog

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    With fd
        .AllowMultiSelect = False
        ' Set the title of the dialog box.
        .Title = "Please Select the file."
        ' Clear out the current filters, and add our own.
        .Filters.Clear
        .Filters.Add "Report Export", "*.csv"
        .Filters.Add "All Files", "*.*"
        ' Show the dialog box. If the .Show method returns True, the
        ' user picked at least one file. If the .Show method returns
        ' False, the user clicked Cancel.
        If .Show = True Then
            TextBox1 = .SelectedItems(1)
        End If
    End With

End Sub
'****************************************

Private Sub Convert_Click()

    If TextBox1.Value = "" Then
        MsgBox "Please Select a file first!"
    Else
        Workbooks.Open Filename:=TextBox1ActiveSheet.Name = "REPORT"

        'DELETES BLANK ROWS
        Dim iCounter As Long
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            For iCounter = Selection.Rows.Count To 1 Step -1
                If WorksheetFunction.CountA(Selection.Rows(iCounter)) = 0 Then
                    Selection.Rows(iCounter).EntireRow.Delete
                End If
            Next iCounter
            .Calculation = xlCalculationAutomatic
            .ScreenUpdating = True
        End With
        '************************
        Dim rngToSearch As Range
        Dim WhatToFind As Variant
        Dim iCtr    As Long

        Set rngToSearch = ThisWorkbook.Worksheets("REPORT").Range("A1:Z1")

        WhatToFind = Array("Card Type")        'add all Column header that you want to check

        With rngToSearch
            For iCtr = LBound(WhatToFind) To UBound(WhatToFind)
                If WorksheetFunction.CountIf(rngToSearch, WhatToFind(iCtr)) > 0 Then        ' Check if column is preset or not
                    ' CODE if column exists
                    '********START CC********
                    'DELETES UNUSED COLUMNS

                    Dim currentColumn As Integer
                    Dim columnHeading As String

                    ActiveSheet.Columns("Z").Delete
                    For currentColumn = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
                        columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value

                        'CHECK WHETHER TO KEEP THE COLUMN
                        Select Case columnHeading
                            Case "User", "Effective Date", "Account", "Customer Name", "Email", "Auth Amount", "Auth Status", "Auth Code"
                                'Do nothing
                            Case Else
                                'Delete if the cell doesn't contain "Homer"
                                If InStr(1, ActiveSheet.UsedRange.Cells(1, currentColumn).Value, _
                                    "Homer", vbBinaryCompare) = 0 Then
                                    ActiveSheet.Columns(currentColumn).Delete
                                End If
                        End Select
                    Next

                    'Format Sheets
                    '****Column User****
                    Dim colUser As Long
                    Dim ColumnUser As Long
                    'Get Column User
                    colUser = WorksheetFunction.Match("User", Rows("1:1"), 0)
                    'Convert To Column Letter
                    ColumnUser = Split(Cells(1, colUser).Address, "$")(1)

                    '****Column EffectiveDate****
                    Dim colEffectiveDate As Long
                    Dim ColumnEffectiveDate As Long
                    'Get Column EffectiveDate
                    colEffectiveDate = WorksheetFunction.Match("Effective Date", Rows("1:1"), 0)
                    'Convert To Column Letter
                    ColumnEffectiveDate = Split(Cells(1, colEffectiveDate).Address, "$")(1)

                    '****Column Account****
                    Dim colAccount As Long
                    Dim ColumnAccount As Long
                    'Get Column Account
                    colAccount = WorksheetFunction.Match("Account", Rows("1:1"), 0)
                    'Convert To Column Letter
                    ColumnAccount = Split(Cells(1, colAccount).Address, "$")(1)

                    '****Column CustName****
                    Dim colCustName As Long
                    Dim ColumnCustName As Long
                    'Get Column Account
                    colCustName = WorksheetFunction.Match("Customer Name", Rows("1:1"), 0)
                    'Convert To Column Letter
                    ColumnCustName = Split(Cells(1, colCustName).Address, "$")(1)

                    '****Column CustEmail****
                    Dim colCustEmail As Long
                    Dim ColumnCustEmail As Long
                    'Get Column Account
                    colCustEmail = WorksheetFunction.Match("Email", Rows("1:1"), 0)
                    'Convert To Column Letter
                    ColumnCustEmail = Split(Cells(1, colCustEmail).Address, "$")(1)

                    '****Column Amount****
                    Dim colAmount As Long
                    Dim ColumnAmount As Long
                    'Get Column Account
                    colAmount = WorksheetFunction.Match("Auth Amount", Rows("1:1"), 0)
                    'Convert To Column Letter
                    ColumnAmount = Split(Cells(1, colAmount).Address, "$")(1)

                    '****Column AuthStatus****
                    Dim colAuthStatus As Long
                    Dim ColumnAuthStatus As Long
                    'Get Column Account
                    colAuthStatus = WorksheetFunction.Match("Auth Status", Rows("1:1"), 0)
                    'Convert To Column Letter
                    ColumnAuthStatus = Split(Cells(1, colAuthStatus).Address, "$")(1)

                    '****Column AuthCode****
                    Dim colAuthCode As Long
                    Dim ColumnAuthCode As Long
                    'Get Column Account
                    colAuthCode = WorksheetFunction.Match("Auth Code", Rows("1:1"), 0)
                    'Convert To Column Letter
                    ColumnAuthCode = Split(Cells(1, colAuthCode).Address, "$")(1)

                    ' Sets Column Widths
                    Worksheets("REPORT").Range(ColumnUser & ":" & ColumnAuthCode).EntireColumn.AutoFit
                    Worksheets("REPORT").Range(ColumnCustName & ":" & ColumnCustEmail).ColumnWidth = 30

                    ' Turns Word Wrap ON
                    Worksheets("REPORT").Range(ColumnUser & ":" & ColumnAuthCode).WrapText = True
                    Worksheets("REPORT").Range(ColumnUser & ":" & ColumnAuthCode).VerticalAlignment = xlVAlignTop
                    Worksheets("REPORT").Range(ColumnUser & ":" & ColumnAuthCode).HorizontalAlignment = xlHAlignLeft
                    Worksheets("REPORT").Range("A1").EntireRow.Font.Bold = True
                    Worksheets("REPORT").Range("A1").EntireRow.Font.Size = 12

                    ' Set Page Settings
                    ActiveSheet.Range(ColumnUser & ":" & ColumnAuthCode).CurrentRegion
                    With ActiveSheet.PageSetup
                        .Orientation = xlLandscape
                        .Zoom = False
                        .FitToPagesWide = 1
                        .FitToPagesTall = False
                        .LeftMargin = Application.InchesToPoints(0.25)
                        .RightMargin = Application.InchesToPoints(0.25)
                        .BottomMargin = Application.InchesToPoints(0.25)
                        .TopMargin = Application.InchesToPoints(0.25)
                    End With

                    'Finds the last non-blank cell in a single row or column
                    Dim lRow As Long

                    'Find the last non-blank cell
                    lRow = Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, _
                        LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row

                    ' Row color change
                    Dim i   As Integer
                    For i = 2 To lRow
                        If i Mod 2 = 0 Then
                            ActiveSheet.Range(ActiveSheet.Cells(i, 1), ActiveSheet.Cells(i, _
                                lCol)).Select
                            With Selection.Interior
                                .Pattern = xlSolid
                                .PatternColorIndex = xlAutomatic
                                .ThemeColor = xlThemeColorAccent6
                                .TintAndShade = 0.799981688894314
                                .PatternTintAndShade = 0
                            End With
                        End If
                    Next i

                    ' Add Totals
                    Dim LastRow As Long
                    Dim bottomRow As Long

                    LastRow = Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, _
                        LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row

                    If LastRow >= 2 Then
                        Cells(LastRow + 2, ColumnAmount).Formula = "=SUM(" & ColumnAmount & _
                            "2" & ":" & ColumnAmount & LastRow & ")"
                    ElseIf LastRow < 2 Then
                        Cells(LastRow + 2, ColumnAmount).Value = Range(ColumnAmount & _
                            "2").Value
                    End If

                    Cells(lRow + 2, ColumnCustEmail).Value = "Total:"

                    bottomRow = lRow + 2
                    Let Copyrange = ColumnCustEmail & bottomRow & ":" & ColumnAmount & bottomRow
                    Range(Copyrange).BorderAround ColorIndex:=3, Weight:=xlThick

                    Range(Copyrange).Font.Bold = True
                    Range(Copyrange).Font.Size = 14

                    ' Add Auto Print HERE
                    Worksheets("REPORT").PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False

                    Application.DisplayAlerts = False
                    Application.Quit
                End If

                Exit Sub
                '*********End of CCs**********
'==========================================================='
' this is your problem
'           Else
' delete this ^^
'==========================================================='
                ' CODE if column is Not Found
                '********CHECKS********

                'DELETES UNUSED COLUMNS
                ActiveSheet.Columns("Z").Delete
                For currentColumn = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
                    columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value

                    'CHECK WHETHER TO KEEP THE COLUMN
                    Select Case columnHeading
                        Case "User", "Payment Date", "Account", "Customer Name", "Customer Email", "Amount", "Comment"
                            'Do nothing
                        Case Else
                            'Delete if the cell doesn't contain "Homer"
                            If InStr(1, ActiveSheet.UsedRange.Cells(1, currentColumn).Value, "Homer", _
                                vbBinaryCompare) = 0 Then
                                ActiveSheet.Columns(currentColumn).Delete
                            End If
                    End Select
                Next

                'Format Sheets
                '****Column User****
                'Get Column User
                colUser = WorksheetFunction.Match("User", Rows("1:1"), 0)
                'Convert To Column Letter
                ColumnUser = Split(Cells(1, colUser).Address, "$")(1)

                '****Column PaymentDate****
                Dim colPaymentDate  As Long
                Dim ColumnPaymentDate As Long
                'Get Column PaymentDate
                colPaymentDate = WorksheetFunction.Match("Payment Date", Rows("1:1"), 0)
                'Convert To Column Letter
                ColumnPaymentDate = Split(Cells(1, colPaymentDate).Address, "$")(1)

                '****Column Account****
                'Get Column Account
                colAccount = WorksheetFunction.Match("Account", Rows("1:1"), 0)
                'Convert To Column Letter
                ColumnAccount = Split(Cells(1, colAccount).Address, "$")(1)

                '****Column CustName****
                'Get Column Account
                colCustName = WorksheetFunction.Match("Customer Name", Rows("1:1"), 0)
                'Convert To Column Letter
                ColumnCustName = Split(Cells(1, colCustName).Address, "$")(1)

                '****Column CustEmail****
                'Get Column Account
                colCustEmail = WorksheetFunction.Match("Customer Email", Rows("1:1"), 0)
                'Convert To Column Letter
                ColumnCustEmail = Split(Cells(1, colCustEmail).Address, "$")(1)

                '****Column Amount****
                'Get Column Account
                colAmount = WorksheetFunction.Match("Amount", Rows("1:1"), 0)
                'Convert To Column Letter
                ColumnAmount = Split(Cells(1, colAmount).Address, "$")(1)

                '****Column Comment****
                Dim colComment      As Long
                Dim ColumnComment   As Long
                'Get Column Account
                colComment = WorksheetFunction.Match("Comment", Rows("1:1"), 0)
                'Convert To Column Letter
                ColumnComment = Split(Cells(1, colComment).Address, "$")(1)

                ' Sets Column Widths
                Worksheets("REPORT").Range(ColumnUser & ":" & ColumnComment).EntireColumn.AutoFit
                Worksheets("REPORT").Range(ColumnCustName & ":" & ColumnCustEmail).ColumnWidth = 30
                Worksheets("REPORT").Range(ColumnComment & ":" & ColumnComment).ColumnWidth = 50

                ' Turns Word Wrap ON
                Worksheets("REPORT").Range(ColumnUser & ":" & ColumnComment).WrapText = True
                Worksheets("REPORT").Range(ColumnUser & ":" & ColumnComment).VerticalAlignment = xlVAlignTop
                Worksheets("REPORT").Range(ColumnUser & ":" & ColumnComment).HorizontalAlignment = xlHAlignLeft
                Worksheets("REPORT").Range("A1").EntireRow.Font.Bold = True
                Worksheets("REPORT").Range("A1").EntireRow.Font.Size = 12

                ' Set Page Settings
                ActiveSheet.Range(ColumnUser & ":" & ColumnComment).CurrentRegion
                With ActiveSheet.PageSetup
                    .Orientation = xlLandscape
                    .Zoom = False
                    .FitToPagesWide = 1
                    .FitToPagesTall = False
                    .LeftMargin = Application.InchesToPoints(0.25)
                    .RightMargin = Application.InchesToPoints(0.25)
                    .BottomMargin = Application.InchesToPoints(0.25)
                    .TopMargin = Application.InchesToPoints(0.25)
                End With

                'Finds the last non-blank cell in a single row or column

                'Find the last non-blank cell
                lRow = Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, _
                    LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row

                ' Row color change
                For i = 2 To lRow
                    If i Mod 2 = 0 Then
                        ActiveSheet.Range(ActiveSheet.Cells(i, 1), ActiveSheet.Cells(i, lCol)).Select
                        With Selection.Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .ThemeColor = xlThemeColorAccent6
                            .TintAndShade = 0.799981688894314
                            .PatternTintAndShade = 0
                        End With
                    End If
                Next i

                ' Add Totals
                LastRow = Cells.Find(What:="*", After:=Range("A1"), _
                    LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, MatchCase:=False).Row

                If LastRow >= 2 Then
                    Cells(LastRow + 2, ColumnAmount).Formula = "=SUM(" & ColumnAmount & "2" & ":" & ColumnAmount & LastRow & ")"
                ElseIf LastRow < 2 Then
                    Cells(LastRow + 2, ColumnAmount).Value = Range(ColumnAmount & "2").Value
                End If

                Cells(lRow + 2, ColumnCustEmail).Value = "Total:"

                bottomRow = lRow + 2
                Let Copyrange = ColumnCustEmail & bottomRow & ":" & ColumnAmount & bottomRow
                Range(Copyrange).BorderAround _
                ColorIndex:=3, Weight:=xlThick

                Range(Copyrange).Font.Bold = True
                Range(Copyrange).Font.Size = 14

                ' Add Auto Print HERE
                Worksheets("REPORT").PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False

                Application.DisplayAlerts = False
                Application.Quit
'==========================================================='
' this is your problem
'            End If
' delete this ^^
'==========================================================='

                Exit Sub
            '********END CHECKS*********
'==========================================================='
' this is your problem
'            End If
' delete this ^^
'==========================================================='

            Next iCtr
        End With
'==========================================================='
' this is your problem
    End If
' added this ^^
'==========================================================='
End Sub
0 голосов
/ 05 февраля 2020

проблема здесь: 

    '*********End of CCs**********

Else
    ' CODE if column is Not Found
    '********CHECKS********

end sub кажется неуместным. Либо создайте новый саб, либо удалите его.

Как сказал комментатор, сделайте вкладку симметричной go далеко. Также напишите короткие функции . Когда я впервые начал это делать, я чувствовал, что пишу слишком много подпрограмм. Но это делает код невероятно простым для понимания.

Я пишу подпрограмму "Main", а затем заставляю ее вызывать все остальные функции. Много сократил мои ошибки.

Ура!

...