I have been tasked with making a vba script that has a userform with a text field, browse button, and convert button. It takes two different .csv files, checks to see if a certain column exists, if it does performs one set of formatting and column removal based on header names. If not performs a different set of formatting based on header names. After that it prints out on the default printer.
I have stitched many different solutions from many different talented people, as well as my own code. Each one on their own worked perfectly when testing one at a time. Once I placed them all together I hit a snag.
I got the error
"Compile error: Else without If"
I searched and found numerous threads where people stated if you add any statement after the then on the same line it closes the if statement. I check my code and could not find any instance of that.
I've been staring at the same chunk of code for days now and am no closer to a solution. I was hoping a fresh set of willing eyes may spot the area I goofed on.
Any and all suggestions or recommendations are welcome!
Thank you all in advanced.
'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
Aucun commentaire:
Enregistrer un commentaire