I have a code that contains nested if statements, I am getting either an "End With without With" or an "End If without If" errors. I need help what I should change in my code. Here is the logic I need to create:
I have two sheets, one is called "OUTGOING ACH" and the other is called "OUTGOING WIRE". I am trying to check their contents, whatever doesn't have content should be deleted and the other one should be reformatted and called "OUTGOING". If both have contents, reformat them, combine them in one of the sheets, call it "OUTGOING", and delete the other one.
Here is a simple version of my code annotations:
'If OUTGOING ACH is empty Then
'Delete OUTGOING ACH
'If OUTGOING WIRE is empty
'Delete OUTGOING WIRE
'Else If OUTGOING WIRE isn't empty
'Reformat OUTGOING WIRE
'Rename OUTGOING WIRE to "OUTGOING"
'End If
'Else If OUTGOING ACH isn't empty Then
'Reformat OUTGOING ACH
'Rename OUTGOING ACH to "OUTGOING"
'If OUTGOING WIRE is empty
'Delete OUTGOING WIRE
'Else If OUTGOING WIRE isn't empty
'Reformat OUTGOING WIRE
'Copy OUTGOING WIRE to OUTGOING (formerly "OUTGOING ACH")
'Delete OUTGOING WIRE
'End If
'End If
I previously defined Header and Bottom as the header row and the last row with data. Here is the full code:
With NewBatch.Sheets("OUTGOING ACH")
Bottom = .Cells(.Rows.Count, 1).End(xlUp).Row
Header = Application.Match("Account*", .Range("A:A"), 0)
If Bottom = Header Then 'If Outgoing ACH is empty >> If 1
Application.DisplayAlerts = False 'Delete it and go to Outgoing wire
NewBatch.Sheets("OUTGOING ACH").Delete
Application.DisplayAlerts = True
End With
With NewBatch.Sheets("OUTGOING WIRE")
Bottom = .Cells(.Rows.Count, 1).End(xlUp).Row
Header = Application.Match("Account*", .Range("A:A"), 0)
If Bottom = Header Then 'If Outgoing wire is also empty >> If 2
Application.DisplayAlerts = False 'Delete it also
NewBatch.Sheets("OUTGOING WIRE").Delete
Application.DisplayAlerts = True
ElseIf Bottom <> Header Then 'But if Outgoing wire is not empty >> Else 2
.Activate 'Reformat OUTGOING WIRE
.Columns("B:D").Delete Shift:=xlToLeft
.Columns("C:Z").Delete Shift:=xlToLeft
.Columns("A:A").Insert Shift:=xlToRight
.Columns("A:A").Insert Shift:=xlToRight
.Columns("A:A").Insert Shift:=xlToRight
.Columns("E:E").Cut
.Columns("D:D").Insert Shift:=xlToRight
.Range("A" & Header).Select
Selection.FormulaR1C1 = "Payment Account (Kyriba Account Code)"
ActiveCell.Offset(0, 1).Select
Selection.FormulaR1C1 = "Transaction Code (CCD, PPD, FEDW, INTW, or DDBT)"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "Transaction Date (mm/dd/yyyy)"
ActiveCell.Offset(0, 2).Select
ActiveCell.FormulaR1C1 = "Third Party"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "CCY"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "Batch ID"
.Range(("E" & Header + 1) & ":" & "E" & Bottom).Copy
.Range(("A" & Header + 1) & ":" & "A" & Bottom).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range(("B" & Header + 1) & ":" & "B" & Bottom).Value = "FEDW"
.Range(("C" & Header + 1) & ":" & "C" & Bottom).Value = Date
.Range(("F" & Header + 1) & ":" & "F" & Bottom).Value = "USD"
.Range(("G" & Header + 1) & ":" & "G" & Bottom).Value = Format(Now, "mmddyyyyhmmss")
.Range(("G" & Header + 1) & ":" & "G" & Bottom).NumberFormat = "#"
.Range("H" & Header).Value = "-1"
.Range("H" & Header).Copy
.Range(("D" & Header + 1) & ":" & "D" & Bottom).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False
.Range("H" & Header).ClearContents
.Rows("1:" & Header - 1).Delete Shift:=xlUp
.Cells.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
.Bold = False
End With
With Selection.Borders
.LineStyle = xlNone
End With
With Selection
.WrapText = False
.EntireColumn.AutoFit
.EntireRow.AutoFit
End With
.Columns("D:D").NumberFormat = "0.00"
.Range("A1").Select
.Name = ("OUTGOING")
End If '>> End of If 2 (ACH is empty and whether or not Wire is empty)
End With
'Now, if Outgoing ACH wasn't empty >> Else If 1
'First reformat Outgoing ACH
With NewBatch.Sheets("OUTGOING ACH")
Bottom = .Cells(.Rows.Count, 1).End(xlUp).Row
Header = Application.Match("Account*", .Range("A:A"), 0)
ElseIf Bottom <> Header Then
.Activate
.Columns("B:D").Delete Shift:=xlToLeft
.Columns("C:Z").Delete Shift:=xlToLeft
.Columns("A:A").Insert Shift:=xlToRight
.Columns("A:A").Insert Shift:=xlToRight
.Columns("A:A").Insert Shift:=xlToRight
.Columns("E:E").Cut
.Columns("D:D").Insert Shift:=xlToRight
.Range("A" & Header).Select
Selection.FormulaR1C1 = "Payment Account (Kyriba Account Code)"
ActiveCell.Offset(0, 1).Select
Selection.FormulaR1C1 = "Transaction Code (CCD, PPD, FEDW, INTW, or DDBT)"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "Transaction Date (mm/dd/yyyy)"
ActiveCell.Offset(0, 2).Select
ActiveCell.FormulaR1C1 = "Third Party"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "CCY"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "Batch ID"
.Range(("E" & Header + 1) & ":" & "E" & Bottom).Copy
.Range(("A" & Header + 1) & ":" & "A" & Bottom).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range(("B" & Header + 1) & ":" & "B" & Bottom).Value = "CCD"
.Range(("C" & Header + 1) & ":" & "C" & Bottom).Value = Date
.Range(("F" & Header + 1) & ":" & "F" & Bottom).Value = "USD"
.Range(("G" & Header + 1) & ":" & "G" & Bottom).Value = Format(Now, "mmddyyyyhmmss")
.Range(("G" & Header + 1) & ":" & "G" & Bottom).NumberFormat = "#"
.Range("H" & Header).Value = "-1"
.Range("H" & Header).Copy
.Range(("D" & Header + 1) & ":" & "D" & Bottom).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False
.Range("H" & Header).ClearContents
.Rows("1:" & Header - 1).Delete Shift:=xlUp
.Cells.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
.Bold = False
End With
With Selection.Borders
.LineStyle = xlNone
End With
With Selection
.WrapText = False
.EntireColumn.AutoFit
.EntireRow.AutoFit
End With
.Columns("D:D").NumberFormat = "0.00"
.Range("A1").Select
.Name = ("OUTGOING")
End With
With NewBatch.Sheets("OUTGOING WIRE") 'Then check if Ougoing Wire is empty
Bottom = .Cells(.Rows.Count, 1).End(xlUp).Row
Header = Application.Match("Account*", .Range("A:A"), 0)
If Bottom = Header Then 'If Outgoing Wire is empty >> If 3
Application.DisplayAlerts = False 'Delete Outgoing Wire
NewBatch.Sheets("OUTGOING WIRE").Delete
Application.DisplayAlerts = True
ElseIf Bottom <> Header Then 'If Outgoing Wire isn't empty (both aren't empty) >> Else if 3
.Activate 'Reformat outgoing wire
.Columns("B:D").Delete Shift:=xlToLeft
.Columns("C:Z").Delete Shift:=xlToLeft
.Columns("A:A").Insert Shift:=xlToRight
.Columns("A:A").Insert Shift:=xlToRight
.Columns("A:A").Insert Shift:=xlToRight
.Columns("E:E").Cut
.Columns("D:D").Insert Shift:=xlToRight
.Range("A" & Header).Select
.Selection.FormulaR1C1 = "Payment Account (Kyriba Account Code)"
ActiveCell.Offset(0, 1).Select
Selection.FormulaR1C1 = "Transaction Code (CCD, PPD, FEDW, INTW, or DDBT)"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "Transaction Date (mm/dd/yyyy)"
ActiveCell.Offset(0, 2).Select
ActiveCell.FormulaR1C1 = "Third Party"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "CCY"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "Batch ID"
.Range(("E" & Header + 1) & ":" & "E" & Bottom).Copy
.Range(("A" & Header + 1) & ":" & "A" & Bottom).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range(("B" & Header + 1) & ":" & "B" & Bottom).Value = "FEDW"
.Range(("C" & Header + 1) & ":" & "C" & Bottom).Value = Date
.Range(("F" & Header + 1) & ":" & "F" & Bottom).Value = "USD"
.Range(("G" & Header + 1) & ":" & "G" & Bottom).Value = Format(Now, "mmddyyyyhmmss")
.Range(("G" & Header + 1) & ":" & "G" & Bottom).NumberFormat = "#"
.Range("H" & Header).Value = "-1"
.Range("H" & Header).Copy
.Range(("D" & Header + 1) & ":" & "D" & Bottom).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False
.Range("H" & Header).ClearContents
.Rows("1:" & Header - 1).Delete Shift:=xlUp
.Cells.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
.Bold = False
End With
With Selection.Borders
.LineStyle = xlNone
End With
With Selection.Borders
.WrapText = False
.EntireColumn.AutoFit
.EntireRow.AutoFit
End With
.Columns("D:D").NumberFormat = "0.00"
Bottom = WorksheetFunction.Match((Cells(Rows.Count, 1).End(xlUp)), Range("A:A"), 0)
.Rows("2" & ":" & Bottom).Copy
End With
With NewBatch.Sheets("OUTGOING")
Bottom = WorksheetFunction.Match((Cells(Rows.Count, 1).End(xlUp)), Range("A:A"), 0)
.Rows(Bottom + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("A1").Select
End With
Application.DisplayAlerts = False
Sheets("OUTGOING WIRE").Delete
Application.DisplayAlerts = True
End If 'End of If 3 (ACH isn't empty and whether or not wire is empty)
End If 'End of If 1 (The whole test for ACH and Outgoing Wire)
I tried to reposition End If and End With but that didn't work.
Thanks!
As others have pointed out there are many errors in your code, but to name a few:
With NewBatch.Sheets("OUTGOING ACH")
Bottom = .Cells(.Rows.Count, 1).End(xlUp).Row
Header = Application.Match("Account*", .Range("A:A"), 0)
If Bottom = Header Then 'If Outgoing ACH is empty >> If 1
Application.DisplayAlerts = False 'Delete it and go to Outgoing wire
NewBatch.Sheets("OUTGOING ACH").Delete
Application.DisplayAlerts = True
End If '<= this is the closing `End If` for 'If Bottom = Header Then'
End With
Further, the section staring with:
With NewBatch.Sheets("OUTGOING ACH")
Bottom = .Cells(.Rows.Count, 1).End(xlUp).Row
Header = Application.Match("Account*", .Range("A:A"), 0)
If (something = true) Then '<= Missing `If` initialization in your code
'do something
ElseIf Bottom <> Header Then
'whole bunch of code ending with last few lines as per below
.Columns("D:D").NumberFormat = "0.00"
.Range("A1").Select
.Name = ("OUTGOING")
End If '<= Missing `End If` statement to close the `If (something = true) Then' statement
End With
Subsequently section starting with:
With NewBatch.Sheets("OUTGOING WIRE") 'Then check if Ougoing Wire is empty
Bottom = .Cells(.Rows.Count, 1).End(xlUp).Row
Header = Application.Match("Account*", .Range("A:A"), 0)
If Bottom = Header Then 'If Outgoing Wire is empty >> If 3
Application.DisplayAlerts = False 'Delete Outgoing Wire
NewBatch.Sheets("OUTGOING WIRE").Delete
Application.DisplayAlerts = True
ElseIf Bottom <> Header Then
'whole bunch of code ending with last few lines as per below
.Columns("D:D").NumberFormat = "0.00"
Bottom = WorksheetFunction.Match((Cells(Rows.Count, 1).End(xlUp)), Range("A:A"), 0)
.Rows("2" & ":" & Bottom).Copy
End If '<= Missing 'End If' to close the 'If Bottom = Header Then' statement
End With
Finally:
With NewBatch.Sheets("OUTGOING")
Bottom = WorksheetFunction.Match((Cells(Rows.Count, 1).End(xlUp)), Range("A:A"), 0)
.Rows(Bottom + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("A1").Select
End With
Application.DisplayAlerts = False
Sheets("OUTGOING WIRE").Delete
Application.DisplayAlerts = True
End If 'End of If 3 (ACH isn't empty and whether or not wire is empty)
End If '<= These last two 'End If' statements do not have an opening statement? i.e. a corresponding 'If (something = true) Then'
Remember to correctly encapsulate your If statements as they should be within the With statement
With <something>
If (something = true) Then
'do something
ElseIf (somethingElse = true) Then
'do something else
Else
'do fallback
End If
End With
Related
I am a bit stuck: I have the below code for a spreadsheet which copies rows, selected with a checkbox, into a second sheet.
I now need to amend this code so that the copied rows are pasted into another workbook on a specific sheet.
I have tried Workbooks("").Worksheets("") and also using the whole C drive path but always get a run-time 9, subscript out of range error. I haven't had any luck in finding a solution online.
Both workbooks are saved on my desktop currently for ease:
Sub CopyRows()
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = 1 Then
For r = 1 To Rows.Count
If Cells(r, 1).Top = chkbx.Top Then
With Worksheets("Sheet2")
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & LRow & ":R" & LRow) = _
Worksheets("Sheet1").Range("A" & r & ":R" & r).Value
End With
Exit For
End If
Next r
End If
Next
End Sub
This recorded macro takes the data to where it needs to go:
Sub Transfer()
'
' Transfer Macro
'
'
Range("K2").Select
Selection.Copy
Windows("Destination.xls").Activate
Range("E7:E8").Select
ActiveSheet.Paste
Windows("WIP - Live.xlsm").Activate
Range("B2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Destination.xls").Activate
Range("E9").Select
ActiveSheet.Paste
Windows("WIP - Live.xlsm").Activate
Range("M2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Destination.xls").Activate
Range("E10").Select
ActiveSheet.Paste
Windows("WIP - Live.xlsm").Activate
Range("G2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Destination.xls").Activate
Range("E11").Select
ActiveSheet.Paste
Windows("WIP - Live.xlsm").Activate
Range("N2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Destination.xls").Activate
Range("E12").Select
ActiveSheet.Paste
Windows("WIP - Live.xlsm").Activate
Range("E2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Destination.xls").Activate
Range("E13").Select
ActiveSheet.Paste
Windows("WIP - Live.xlsm").Activate
Range("A2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Destination.xls").Activate
Range("E14").Select
ActiveSheet.Paste
Windows("WIP - Live.xlsm").Activate
Range("S2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Destination.xls").Activate
Range("E15").Select
ActiveSheet.Paste
Windows("WIP - Live.xlsm").Activate
Range("J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Destination.xls").Activate
Range("E16").Select
ActiveSheet.Paste
Windows("WIP - Live.xlsm").Activate
Range("I2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Destination.xls").Activate
Range("E17").Select
ActiveSheet.Paste
Windows("WIP - Live.xlsm").Activate
Range("C2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Destination.xls").Activate
Range("E20").Select
ActiveSheet.Paste
Windows("WIP - Live.xlsm").Activate
Range("D2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Destination.xls").Activate
Range("E21").Select
ActiveSheet.Paste
Windows("WIP - Live.xlsm").Activate
End Sub
Code with error at destination workbook:
Sub CopyRows()
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = 1 Then
For r = 1 To Rows.Count
If Cells(r, 1).Top = chkbx.Top Then
With Workbooks("Destination").Sheets("Sheet2")
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & LRow & ":R" & LRow) = _
Worksheets("Sheet1").Range("A" & r & ":R" & r).Value
End With
Exit For
End If
Next r
End If
Next
End Sub
Solved: I have managed to get it working with the below code:
Sub CopyRows()
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = 1 Then
For r = 1 To Rows.Count
If Cells(r, 1).Top = chkbx.Top Then
With Workbooks("Destination.xlsm").Sheets("Details")
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & LRow & ":U" & LRow) = _
Worksheets("Sheet2").Range("A" & r & ":U" & r).Value
End With
Exit For
End If
Next r
End If
Next
End Sub
The error was being caused by the Sheet 2 name in the destination workbook. I had to amend the name to details and it started working. Frustratingly simple for how long I spent on it!
Many Thanks to ed2 and norie for the replies and help. It is much appreciated.
Try this:
First:
Change
Worksheets("Sheet1").Range("A" & r & ":R" & r).Value
to
Workbooks("WIP - Live.xlsm").Sheets("Sheet1").Range("A" & r & ":R" & r).Value
Then:
Change
With Worksheets("Sheet2")
to
Workbooks("Destination.xls").Sheets("Sheet2")
This assumes that both workbooks are already open when the macro is run. If not, you will need code to open one or both of them.
I have a question about a problem that I can't seem to solve.
I have some VBA-code that includes a picture in a cell:
fNameAndPath = UserForm1.ComboBox2.Value
Set img = Application.ActiveSheet.Shapes.AddPicture(fNameAndPath, False, True, 1, 1, 1, 1)
With img
.Left = ActiveSheet.Range("G" & Lastrow).Left
.Top = ActiveSheet.Range("G" & Lastrow).Top
.Width = ActiveSheet.Range("G" & Lastrow).Width
.Height = ActiveSheet.Range("G" & Lastrow).Height
.Placement = 1
End With
This code runs perfectly for myself. The pictures are beautifully inserted.
However, 20% of my colleagues who use the macro find their picture in column H instead of column G.
I cannot come up with a reason why this happens.
Someone who encountered a related issue?
Thank you
Sorry for the delay, hereby the whole code that is in this macro.
Sub CommandButton3_Click()
‘ check whether conditions are OK
If UserForm1.TextBox1.Value = "" Or UserForm1.TextBox2.Value = "" Or UserForm1.TextBox3.Value = "" Or UserForm1.ComboBox1.Value = "" Then
MsgBox ("")
Exit Sub
End If
‘Check whether a picture was attached
If UserForm1.ComboBox2.Value = "" Then
MsgBox ("")
Exit Sub
End If
Workbooks("").Sheets("").Unprotect ""
‘Find username of the user
Dim username As String
username = Environ("username")
‘define lastrow and write some data in the cells
Lastrow = Worksheets("Objets Inutiles").Range("A650000").End(xlUp).Row + 1
Worksheets("Objets Inutiles").Range("A" & Lastrow).Value = "=Now()"
Worksheets("Objets Inutiles").Range("A" & Lastrow).Select
Selection.Copy
Worksheets("Objets Inutiles").Range("A" & Lastrow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("Objets Inutiles").Range("B" & Lastrow).Value = ""
Worksheets("Objets Inutiles").Range("C" & Lastrow).Value = username
Worksheets("Objets Inutiles").Range("C" & Lastrow).Select
Selection.Copy
Worksheets("Objets Inutiles").Range("C" & Lastrow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("Objets Inutiles").Range("D" & Lastrow).Value = UserForm1.ComboBox1.Value
Worksheets("Objets Inutiles").Range("E" & Lastrow).Value = UserForm1.TextBox2.Value
Worksheets("Objets Inutiles").Range("F" & Lastrow).Value = UserForm1.TextBox3.Value
Worksheets("Objets Inutiles").Range("H" & Lastrow).Value = UserForm1.TextBox1.Value
Worksheets("Objets Inutiles").Range("I" & Lastrow).Value = ""
Worksheets("Objets Inutiles").Range("J" & Lastrow).Value = ""
fNameAndPath = UserForm1.ComboBox2.Value
Set img = Application.ActiveSheet.Shapes.AddPicture(fNameAndPath, False, True, 1, 1, 1, 1)
With img
'Resize Picture to fit in the range....
.Left = ActiveSheet.Range("G" & Lastrow).Left
.Top = ActiveSheet.Range("G" & Lastrow).Top
.Width = ActiveSheet.Range("G" & Lastrow).Width
.Height = ActiveSheet.Range("G" & Lastrow).Height
.Placement = 1
End With
‘send some spam around
Dim EmailApp As Outlook.Application
Dim Source As String
Set EmailApp = New Outlook.Application
Dim EmailItem As Outlook.MailItem
Set EmailItem = EmailApp.CreateItem(olMailItem)
EmailItem.To = ""
EmailItem.CC = ""
EmailItem.BCC = ""
EmailItem.Subject = ""
EmailItem.HTMLBody = ""
EmailItem.Send
Unload UserForm1
Workbooks("").Sheets("").Protect ""
Workbooks("").Save
MsgBox ("")
Exit Sub
Unload Me
Workbooks("").Sheets("").Protect "Sapore"
Workbooks("").Save
MsgBox ("")
End Sub
Our company has 36 departments and we use a master budgeting worksheet to develop the budget. The department numbers are not sequential and their budgets are all different. I put together the following macro to send the worksheets to the individual departments. The master is full of VLOOKUPs and other formulae, but the individual departments receive only the final results and a couple of columns for their changes. They can make changes to any number that is not highlighted in yellow. The macro works perfectly for only one department, but when I tried to copy it 35 times below itself so that I could send a worksheet to all departments, I received an error message that said my procedure was too large. I divided it in half and I still received the message!
Sub Macro1()
'
' Macro1 Macro
'' Prepares O&M budget Worksheet for uploading
' Dim sourceSheet as Worksheet
Workbooks.Open Filename:="F:\Rick\2020 Budget\2020 O&M Budget.xlsx"
Set sourcesheet = Worksheets("Dept Detail-O&M Book")
sourcesheet.Activate
' Dim N As Long
' Dim T As Long
' Dim LastRow As Long
lastrow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
Dim i As Long, Total As Long
Dim cell As Range
Application.EnableEvents = False
'
Application.Goto Reference:="Dept_01"
Selection.Copy
Workbooks.Open Filename:="Q:\O&M\Departmental Budgets\Dept 1 MOEC.xlsx"
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
ThisWorkbook.Activate
Application.CutCopyMode = False
Selection.Copy
Windows("Dept 1 MOEC.xlsx").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("R1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Application.CutCopyMode = False
n = Cells(Rows.Count, "R").End(xlUp).Row
Cells(n, "R").Formula = "=SUM(R1:R" & n - 1 & ")"
activecell.Select
Selection.Copy
activecell.Offset(0, 2).Select
ActiveSheet.Paste
Selection.Copy
activecell.Offset(0, 2).Select
ActiveSheet.Paste
Range("X9").Select
activecell.FormulaR1C1 = "=iferror(+RC[-2]/RC[-10],0)"
Range("X9").Select
T = Cells(Rows.Count, "X").End(xlUp).Row
Selection.AutoFill Destination:=Range("x9:x" & T)
With ActiveSheet
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
Application.EnableEvents = False
For i = lastrow To 1 Step -1
If Range("B" & i).Value = "1010" Or _
Range("B" & i).Value = "1020" Or _
Range("B" & i).Value = "2172" Or _
Range("B" & i).Value = "2190" Or _
Range("B" & i).Value = "2200" Or _
Range("B" & i).Value = "2290" Or _
Range("B" & i).Value = "4020" Or _
Range("B" & i).Value = "4050" Or _
Range("B" & i).Value = "4060" Or _
Range("B" & i).Value = "4070" Or _
Range("B" & i).Value = "4090" Or _
Range("B" & i).Value = "4100" Or _
Range("B" & i).Value = "4110" Or _
Range("B" & i).Value = "4509" Or _
Range("B" & i).Value = "4510" Or _
Range("B" & i).Value = "4600" Or _
Range("B" & i).Value = "4610" Or _
Range("B" & i).Value = "4700" Or _
Range("B" & i).Value = "5710" Or _
Range("B" & i).Value = "5721" Or _
Range("B" & i).Value = "5723" Or _
Range("B" & i).Value = "5725" Or _
Range("B" & i).Value = "5729" Or _
Range("B" & i).Value = "5730" Or _
Range("B" & i).Value = "5731" Then
.Range("R" & i).Interior.Color = RGB(255, 255, 0)
.Range("T" & i).Interior.Color = RGB(255, 255, 0)
End If
Next i
Application.EnableEvents = True
End With
With ActiveSheet
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
Application.EnableEvents = False
For i = lastrow To 1 Step -1
If Range("B" & i).Value = "5721" Or _
Range("B" & i).Value = "9000" Or _
Range("B" & i).Value = "9005" Or _
Range("B" & i).Value = "9010" Or _
Range("B" & i).Value = "9030" Then
.Range("R" & i).Interior.Color = RGB(255, 255, 0)
.Range("T" & i).Interior.Color = RGB(255, 255, 0)
End If
Next i
Application.EnableEvents = True
End With
Range("A1").Select
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
Could someone offer suggestions on how to reduce the size of the macro and/or make it more efficient? Thanks!
I took a shot at cleaning this up (at least to make it run, for now) - I don't know enough about what you're doing to clean up that mid section, though. The problem undoubtedly was that long If statement.
Instead of all the Ors, put all your values in an array then test against that array with IsError:
Option Explicit
Sub Macro1()
Dim valuearr As Variant
Dim cell As Range
Dim sourcesheet As Worksheet
Dim lastrow As Long, i As Long, n As Long
Workbooks.Open Filename:="F:\Rick\2020 Budget\2020 O&M Budget.xlsx"
Set sourcesheet = Worksheets("Dept Detail-O&M Book")
sourcesheet.Activate
lastrow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
Application.EnableEvents = False
'This section needs to be cleaned up...
Application.Goto Reference:="Dept_01"
Selection.Copy
Workbooks.Open Filename:="Q:\O&M\Departmental Budgets\Dept 1 MOEC.xlsx"
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
ThisWorkbook.Activate
Application.CutCopyMode = False
Selection.Copy
Windows("Dept 1 MOEC.xlsx").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("R1").Select
Selection.End(xlDown).Select
Application.CutCopyMode = False
n = Cells(Rows.Count, "R").End(xlUp).Row
Cells(n, "R").Formula = "=SUM(R1:R" & n - 1 & ")"
ActiveCell.Copy
ActiveCell.Offset(0, 2).Paste
Selection.Offset(0, 2).Select
ActiveSheet.Paste
Range("X9").FormulaR1C1 = "=iferror(+RC[-2]/RC[-10],0)"
Range("X9").AutoFill Destination:=Range("x9:x" & Cells(Rows.Count, "X").End(xlUp).Row)
With ActiveSheet
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
valuearr = Array(1010, 1020, 2172, 2190, 2200, 2290, 4020, 4050, 4060, 4070, 4090, 4100, 4110, 4509, 4510, 4600, 4610, 4700, 5710, 5721, 5723, 5725, 5729, 5730, 5731, 9000, 9005, 9010, 9030)
For i = lastrow To 1 Step -1
If IsError(Application.Match(Range("B" & i).Value, valuearr, 0)) Then
.Range("R" & i).Interior.Color = RGB(255, 255, 0)
.Range("T" & i).Interior.Color = RGB(255, 255, 0)
End If
Next i
End With
Application.EnableEvents = True
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
I want to repeat this command in subsequent rows every 15th time.So the next one will be J348:M348
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("J318").Select
ActiveCell.FormulaR1C1 = "=R303C10-((R3C2-R4C2)/(R5C2/R6C2))"
Range("K318").Select
ActiveCell.FormulaR1C1 = "=R303C11-((R3C3-R4C3)/(R5C2/R6C2))"
Range("L318").Select
ActiveCell.FormulaR1C1 = "=RC[-5]"
Range("M318").Select
ActiveCell.FormulaR1C1 = "=RC[-5]"
Range("J318:M318").Select
Selection.AutoFill Destination:=Range("J318:M332"), Type:=xlFillDefault
Range("J318:M332").Select
ActiveWindow.SmallScroll Down:=0
Range("J332").Select
ActiveWindow.SmallScroll Down:=15
Range("J333:M333").Select
Selection.Copy
Range("J334").Select
ActiveSheet.Paste
Range("J335").Select
Application.CutCopyMode = False
Selection.Copy
Range("J334:M334").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
For a straight migration of your code to a looped code:
I randomly started at row 5 and used a do while loop. You could just as easily use a for loop. Hopefully this gives you the idea of the looping so you don't have to do it manually.
Public Sub Every15thRow()
Dim i As Integer
Dim iFirst, iSecond, iThird, iFourth, iFifth As Integer
'in Ex: 318, 303, 332, 333, 334
Dim MyStopCriteria As Boolean
MyStopCriteria = False
'... whatever your code does before
'...
i = 5 'start with the 5th row
Do Until MyStopCriteria = True
iFirst = i + 15
iSecond = i
iThird = i + 29
iFourth = i + 30
iFifth = i + 31
Application.CutCopyMode = False
Range("J" & iFirst).Select
ActiveCell.FormulaR1C1 = "=R" & iSecond & "C10-((R3C2-R4C2)/(R5C2/R6C2))"
Range("K" & iFirst).Select
ActiveCell.FormulaR1C1 = "=R" & iSecond & "C11-((R3C3-R4C3)/(R5C2/R6C2))"
Range("L" & iFirst).Select
ActiveCell.FormulaR1C1 = "=RC[-5]"
Range("M" & iFirst).Select
ActiveCell.FormulaR1C1 = "=RC[-5]"
Range("J" & iFirst & ":M" & iFirst).Select
Selection.AutoFill Destination:=Range("J" & iFirst & ":M" & iThird), Type:=xlFillDefault
Range("J" & iFirst & ":M" & iFourth).Select
ActiveWindow.SmallScroll Down:=0
Range("J" & iThird).Select
ActiveWindow.SmallScroll Down:=15
Range("J" & iThird & ":M" & iThird).Select
Selection.Copy
Range("J" & iFourth).Select
ActiveSheet.Paste
Range("J" & iFourth).Select
Application.CutCopyMode = False
Selection.Copy
Range("J" & iFifth & ":M" & iFifth).Select
'...
'... whatever else your repeating code needs to do
'...
i = i + 15 'Add 15 rows
If i > 40 Then MyStopCriteria = True
Loop
'... whatever else your code does after repeating
End Sub
When the excel sheet raw data has under 10,000 rows it runs, when it has 10,000 rows and over I get the error. Any idea? The error is pointed to the mu = Cells(joker, 12)
Columns("A:I").Select
Selection.ClearContents
Windows("New Registrations.xls").Activate
ActiveWindow.WindowState = xlNormal
Columns("A:I").Select
Selection.Copy
Windows("Polk Trend Report CYTD.xlsm").Activate
Range("A1").Select
ActiveSheet.Paste
Selection.Interior.ColorIndex = xlNone
Selection.Font.ColorIndex = 0
Sheets("Data").Select
Dim nz As Long
Dim joker As Long
Dim lambda As Long
nz = Cells(4, 12).Value
Dim mu As Long
For joker = 5 To nz + 4
lambda = Cells(joker, 11)
mu = Cells(joker, 12)
If lambda <> 0 And mu - lambda > 1 Then
Range("A" & lambda).Select
Selection.Copy
Range("A" & lambda + 1 & ":A" & mu - 1).Select
ActiveSheet.Paste
Else:
End If
Next joker
Range("N5:O" & nz + 4).Select
Selection.ClearContents
Dim iota As Long
Dim kappa As Long
iota = 7
Do While Cells(iota, 2).Value <> ""
If Cells(iota, 2) = "UNKNOWN" Then
kappa = Application.WorksheetFunction.Match(Cells(iota, 1).Value, Range("J1:J" & nz + 4), 0)
Cells(kappa, 14).Value = Cells(iota, 7).Value
Cells(kappa, 15).Value = Cells(iota, 5).Value
Range("A" & iota & ":I" & iota).Select
Selection.Delete Shift:=xlUp
iota = iota - 1
ElseIf Cells(iota, 2) = "Zone Total" Then
Range("A" & iota & ":I" & iota).Select
Selection.Delete Shift:=xlUp
iota = iota - 1
ElseIf Application.WorksheetFunction.And(Cells(iota, 5) = 0, Cells(iota, 7) = 0) Then
Range("A" & iota & ":I" & iota).Select
Selection.Delete Shift:=xlUp
iota = iota - 1
Else:
End If
iota = iota + 1
Loop
Range("A" & iota & ":I" & iota).Select
Selection.Delete Shift:=xlUp
Range("C5:I5").Select
Selection.Copy
Range("C6").Select
ActiveSheet.Paste
Set pvtTable = Worksheets("Total Dealer (Trend)").Range("O5").PivotTable
pvtTable.RefreshTable
Sheets("Total Dealer (Trend)").Select
Cells.Select
Selection.Columns.AutoFit
Sheets("Data").Select
Range("S40:T" & nz + 39).Select
Selection.Copy
Range("A2").Select
Sheets("Total Dealer (Trend)").Select
Range("B40").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("Data").Select
Range("U40:U" & nz + 39).Select
Selection.Copy
Range("A2").Select
Sheets("Total Dealer (Trend)").Select
Range("E40").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("B40:E" & nz + 39).Select
Selection.Sort Key1:=Range("E40"), Order1:=xlDescending, Header:=xlNo _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select
ActiveWindow.WindowState = xlMaximized
End Sub
I think you might have a format change taking place on your Worksheet after row 10,000. Say it was a date, now it's General or some other type conflict, and you are getting a data mismatch as a result of the Value of mu being set by
"L10000"
Check the format of the cells below 10,000. Especially Column "L"
this is an example error handler, hopefully you can just copy and paste this into your code as described and it should output the value of the failing cell when the error occurs, and then you can hopefully correct it. The following goes right at the top of your code
On Error GoTo MyProcedure_Error
Then the below goes above the end sub
MyProcedure_Exit:
On Error GoTo 0
Exit Sub
MyProcedure_Error:
Select Case Err.Number
'the "Case 9" statement below is left as an example to show how you could code a
'specific error message if a specifc module needed it
'Case 9
'MsgBox "The input file does not appear to be in the correct format, for importing into the " & _
'" Locations tab" & vbCrLf & "The expected format is " & Str(Import_Cols) & " columns, Pipe Delimited" & _
'vbCrLf, vbCritical, "Error in in procedure TrimColumn of Module DeveloperToolKit"
Case Else
MsgBox "An unexpected error has occured, the call value that has failed is." & _
vbCrLf & Cells(joker, 12) & _
vbCrLf & "Error Code = " & Str$(Err.Number) & _
vbCrLf & "Error Text = " & Err.Description, vbCritical, "Critical Error"
End Select
Resume MyProcedure_Exit