VBA add image in cell gives different results - excel

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

Related

End With without With and End If without If compile error

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

Selecting Multiple Columns with and a Specific Row with For Loop VBA

I'm trying to select multiple columns for i rows depending on a For loop. The idea is to check whether a specific cell meets the criteria. If so, copy the formulas associated with that specific segment to the same row as that observation.
i.e:
for i = 13
If O(i) = segment A, copy and paste formula from $P$1 to P(i)
AND
Copy and paste formulas in T1:CV1 to T(i) : CV (i)
(Please keep in mind there are hidden columns between T and CV, I assume these won't have anything to do with the outcome since they are hidden but wanted to note regardless.)
So far, I've tried using the code : Range("T" & i : "CV" & i).Select . I know this is wrong but just wanted to give an idea. The full code is attached below. Any help is appreciated!
Sub mastersheet()
Dim i As Integer
Sheets("Master").Select
For i = 13 To 400
If Range("O" & i).Value = "A" Then
Range("P1").Select
Selection.Copy
Range("P" & i).Select
ActiveSheet.Paste
Range("T1:CV1").Select
Selection.Copy
Range("T" & i : "CV" & i).Select
ActiveSheet.Paste
ElseIf Range("O" & i).Value = "B" Then
Range("P2").Select
Selection.Copy
Range("P" & i).Select
ActiveSheet.Paste
Range("T2:CV2").Select
Selection.Copy
Range("T" & i : "CV" & i).Select
ActiveSheet.Paste
ElseIf Range("O" & i).Value = "C" Then
Range("P3").Select
Selection.Copy
Range("P" & i).Select
ActiveSheet.Paste
Range("T3:CV3").Select
Selection.Copy
Range("T" & i : "CV" & i).Select
ActiveSheet.Paste
ElseIf Range("O" & i).Value = "D" Then
Range("P4").Select
Selection.Copy
Range("P" & i).Select
ActiveSheet.Paste
Range("T4:CV4").Select
Selection.Copy
Range("T" & i : "CV" & i).Select
ActiveSheet.Paste
ElseIf Range("O" & i).Value = "E" Then
Range("P5").Select
Selection.Copy
Range("P" & i).Select
ActiveSheet.Paste
Range("T5:CV5").Select
Selection.Copy
Range("T" & i : "CV" & i).Select
ActiveSheet.Paste
ElseIf Range("O" & i).Value = "F" Then
Range("P6").Select
Selection.Copy
Range("P" & i).Select
ActiveSheet.Paste
Range("T6:CV6").Select
Selection.Copy
Range("T" & i : "CV" & i).Select
ActiveSheet.Paste
ElseIf Range("O" & i).Value = "G" Then
Range("P7").Select
Selection.Copy
Range("P" & i).Select
ActiveSheet.Paste
Range("T7:CV7").Select
Selection.Copy
Range("T" & i : "CV" & i).Select
ActiveSheet.Paste
ElseIf Range("O" & i).Value = "H" Then
Range("P8").Select
Selection.Copy
Range("P" & i).Select
ActiveSheet.Paste
Range("T8:CV8").Select
Selection.Copy
Range("T" & i : "CV" & i).Select
ActiveSheet.Paste
ElseIf Range("O" & i).Value = "I" Then
Range("P9").Select
Selection.Copy
Range("P" & i).Select
ActiveSheet.Paste
Range("T9:CV9").Select
Selection.Copy
Range("T" & i : "CV" & i).Select
ActiveSheet.Paste
End If
Next i
End Sub
Take a look at Select Case
Sub mastersheet1()
Dim i As Integer, ws As Worksheet, n As Integer
Set ws = Sheets("Master")
With ws
For i = 13 To 400
Select Case .Range("O" & i).Value2
Case "A": n = 1
Case "B": n = 2
Case "C": n = 3
Case "D": n = 4
Case "E": n = 5
Case "F": n = 6
Case "G": n = 7
Case "H": n = 8
Case "I": n = 9
Case Else: n = 0
End Select
If n > 0 Then
.Range("P" & n).Copy .Range("P" & i)
.Range("T" & n & ":CV" & n).Copy .Range("T" & i & ":CV" & i)
End If
Next
End With
End Sub
The problem with the copy/paste method is that it is quite slow and inefficient. I would rather use arrays. Here is an example:
Sub mastersheet()
Dim i As Integer
Dim arr As Variant 'This is for storing the array
Sheets("Master").Select
For i = 13 To 400
If Range("O" & i).Value = "A" Then
'This is faster than copy/pasting
Range("P" & i) = Range("P1")
arr = Range("T1:CV1")
Range("T" & i & ": CV" & i) = arr
End If
Next i
End Sub`
Please, try the next compact code. It does not need any selection:
Sub masterSheet()
Dim sh As Worksheet, i As Long, arr, arrL, arrNo, mtch
Set sh = Sheets("Master")
arrL = Split("A,B,C,D,E,F,G,H,I", ",") 'the array used to match the cell value
arrNo = Array(1, 2, 3, 4, 5, 6, 7, 8, 9) 'the array to return row to be copyed (based on mtch)
arr = sh.Range("O1:O400") 'place the range in an array, for faster iteration
Application.Calculation = xlCalculationManual 'calculate formula result only of the end
For i = 13 To 400
mtch = Application.match(arr(i, 1), arrL, 0) 'match the letter value
If IsNumeric(mtch) Then 'if a match exists:
sh.Range("P" & arrNo(mtch - 1)).Copy Destination:=sh.Range("P" & i) 'use the index from arrNo
sh.Range("T" & arrNo(mtch - 1) & ":CV" & arrNo(mtch - 1)).Copy sh.Range("T" & i) 'use the index from arrNo
End If
Next i
Application.Calculation = xlCalculationAutomatic 'now calculate copied formulas
MsgBox "Ready..."
End Sub

Reducing size of a macro

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

Repeat Command in in excel macro

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

access dynamic email address selection

I am trying to send email to multiple person. But the email address that it should select is based on the user who has logged in. How do i do this? I have a table where I have 5 columns of email ID. Based on who is logged in, the code should go n select that person and send email to all the person in that row.
How do I achieve this? I know how to do in excel but access I am less aware. I am pasting both the codes I know and hv tried.
Sub Mail_ActiveSheet()
Dim OutApp As Object
Dim Outmail As Object
Dim sTo As String
Dim sCC As String
Dim lastrow, i As Integer
Dim sub1, sub2, sub3, body1 As Variant
Dim emailid, cc1, cc2, cc3, cc4, subj, attch, Sourcewb, Outnail, Soucrwb As Object
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
ThisWorkbook.Activate
'Code for Email sheet creation
Call EMAILSHEET_DATA
'Code for emailing schedular to the associates
Worksheets("Email_List").Select
lastrow = ThisWorkbook.Worksheets("Email_List").Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
Set emailid = Worksheets("Email_List").Range("C" & i)
sTo = emailid
Set cc1 = Worksheets("Email_List").Range("D" & i)
'Set cc2 = Worksheets("Email_List").Range("E" & i)
'body1 = Worksheets("Email_List").Range("a" & i)
sCC = cc1 '& ";" & cc2
subj1 = Worksheets("Email_List").Range("F" & i).Value
subj2 = Worksheets("Email_List").Range("G" & i).Value
subj3 = Worksheets("Email_List").Range("H" & i).Value
subj = "Your Schedule for " & subj1 & subj2 & subj3
ActiveWorkbook.Activate
Set Sourcewb = ActiveWorkbook
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(0)
On Error Resume Next
With Outmail
.To = sTo
.CC = sCC
'.BCC=Sbcc
.Subject = subj
.Body = "Hello " & Worksheets("Email_List").Range("a" & i).Value & "," & vbCrLf & vbCrLf & subj & "." _
& vbCrLf & vbCrLf & Worksheets("Email_List").Range("i" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("j" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("k" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("l" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("m" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("n" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("o" & i).Value _
& vbCrLf & vbCrLf & "Note: Please report any scheduling conflicts or errors to your Supervisor." _
& vbCrLf & vbCrLf & "Thank You," & vbCrLf & "gmail.com Management"
.Send
End With
On Error GoTo 0
Set Outmail = Nothing
Set OutApp = Nothing
'ActiveWorkbook.Close False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Next i
ThisWorkbook.Activate
MsgBox ("Thank You! The Schedules have been sent to all the associates.")
End Sub
'DATA FOR EMAIL SHEET
Sub EMAILSHEET_DATA()
Worksheets("Email_list").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Worksheets("Schedules").Select
Range("B15").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Email_List").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Associate_Info!R1C1:R270C7,4,0)"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Associate_Info!R1C1:R270C7,3,0)"
Range("D2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Associate_Info!R1C1:R270C7,4,0)"
Range("E2").Select
'ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-4],Associate_Info!C[-4]:C[-1],4,0)"
ActiveCell.FormulaR1C1 = "Information not available"
Range("F2").Select
ActiveCell.FormulaR1C1 = "=Schedules!R12C5"
Range("G2").Select
ActiveCell.FormulaR1C1 = " to "
Range("H2").Select
ActiveCell.FormulaR1C1 = "=Schedules!R12C17"
Range("I2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C5,""MM/DD/YY"") & "" , "" & Schedules!R13C5 & "" , "" & Schedules!R[13]C[-4] & "" - "" & Schedules!R[13]C[-3]"
Range("J2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C7,""MM/DD/YY"") & "" , "" & Schedules!R13C7 & "" , "" & Schedules!R[13]C[-3] & "" - "" & Schedules!R[13]C[-2]"
Range("K2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C9,""MM/DD/YY"") & "" , "" & Schedules!R13C9 & "" , "" & Schedules!R[13]C[-2] & "" - "" & Schedules!R[13]C[-1]"
Range("L2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C11,""MM/DD/YY"") & "" , "" & Schedules!R13C11 & "" , "" & Schedules!R[13]C[-1] & "" - "" & Schedules!R[13]C[0]"
Range("M2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C13,""MM/DD/YY"") & "" , "" & Schedules!R13C13 & "" , "" & Schedules!R[13]C & "" - "" & Schedules!R[13]C[1]"
Range("N2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C15,""MM/DD/YY"") & "" , "" & Schedules!R13C15 & "" , "" & Schedules!R[13]C[1] & "" - "" & Schedules!R[13]C[2]"
Range("O2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C17,""MM/DD/YY"") & "" , "" & Schedules!R13C17 & "" , "" & Schedules!R[13]C[2] & "" - "" & Schedules!R[13]C[3]"
Range("O2").Select
Selection.End(xlToLeft).Select
Range("B2").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Range("A2").Select
lastrow = Cells(2, 1).End(xlDown).Row
'Range("B2:O" & lastrow).Select
Range("b3:o" & lastrow).Select
'Range("B3:B571").Select
'Range("B571").Activate
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.End(xlUp).Select
Range("B2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.End(xlUp).Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("$A$1:$O$291").AutoFilter Field:=2, Criteria1:="#N/A"
Rows("6:6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter
Range("A1").Select
ActiveWorkbook.Save
End Sub
Public Sub EmailList()
'late Binding
Dim olApp As Object
Dim olemail As Object
Dim strbody As String
'creating new outlook instance
Set olApp = CreateObject("Outlook.Application")
Set olemail = olApp.CreateItem(0)
strbody = "<html> <body> Hi " & Me.FullName & " <br/> <br/> Your leaves have been saved. <br/> Start Date: " & Me.Text8 & " <br/> End Date: " & Me.Text10 & " <br/> <br/> Regards <br/> Walmart.com Management "
Set olApp = CreateObject("Outlook.Application")
Set olemail = olApp.CreateItem(0)
With olemail
.BodyFormat = 2
.Display
.htmlBody = strbody
.to = "reetika.choudhary#gmail.com"
.Subject = "Leaves Applied"
.Send
DoCmd.SetWarnings WarningsOff
End With
End Sub
excel code is as below:
Any help will be highly appreciated! Thanks in advance.
You can use Environ("USERNAME") on a windows system to pull the username from the environment variables:
Sub SO()
Dim username As String
username = Environ("USERNAME")
MsgBox username & " is currently logged on."
End Sub

Resources