Could you guys help me combine these macros yet again?

Coyotex3

Active Member
Joined
Dec 12, 2021
Messages
312
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
Trying to combine these 5 macros into one if possible

VBA Code:
Sub Coyote10()
    Dim LR As Long, i As Long
    Application.ScreenUpdating = False
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Range("I1").EntireColumn.Insert
    Range("I1") = "Address"
    For i = 2 To LR
        Range("I" & i) = Range("E" & i).Value2 & ", " & Range("F" & i).Value2 & ", " & _
                         Range("G" & i).Value2 & " " & Range("H" & i).Value2
    Next i
    Range("E1:H1").EntireColumn.Delete
    Application.ScreenUpdating = True
End Sub
Sub Coyote12A()
    Dim LR As Long, i As Long
    Application.ScreenUpdating = False
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Range("N1").EntireColumn.Insert
    Range("N1") = "City"
    For i = 2 To LR
        Range("N" & i) = Range("J" & i).Value2 & ", " & Range("K" & i).Value2 & ", " & _
                         Range("L" & i).Value2 & " " & Range("M" & i).Value2
    Next i
    Range("J1:M1").EntireColumn.Delete
    Application.ScreenUpdating = True
End Sub
Sub Coyote13A()
    Dim LR As Long, i As Long
    Application.ScreenUpdating = False
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Range("D1").EntireColumn.Insert
    Range("D1") = "Code"
    For i = 2 To LR
        Range("D" & i) = Range("C" & i).Value2 & 4
    Next i
    Application.ScreenUpdating = True
End Sub
Sub Coyote14A()
    Dim LR As Long, i As Long
    Application.ScreenUpdating = False
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Range("E1").EntireColumn.Insert
    Range("E1") = "Alt Code"
    For i = 2 To LR
        Range("E" & i) = Range("C" & i).Value2 & 1
    Next i
    Application.ScreenUpdating = True
End Sub
Sub Coyote15A()
    Dim LR As Long, i As Long
    Application.ScreenUpdating = False
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Range("F1").EntireColumn.Insert
    Range("F1") = "Extra Code"
    For i = 2 To LR
        Range("F" & i) = 201250
    Next i
    Application.ScreenUpdating = True
End Sub
 

Coyotex3

Active Member
Joined
Dec 12, 2021
Messages
312
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
Ok I wrapped it up tonight. Tossed in the array approach in case you have a bunch of rows to handle.

Lemme know how it goes. Should be faster if you have a bunch of rows to go through.

VBA Code:
Sub NewV4()
'
    Dim LR                      As Long, i                          As Long
    Dim Column_C_Array          As Variant, Column_E_Array          As Variant, Column_M_Array          As Variant
    Dim Columns_D_Thru_F_Array  As Variant, Columns_F_Thru_H_Array  As Variant, Columns_N_Thru_P_Array  As Variant
'
    Application.ScreenUpdating = False                                                                  ' Turn ScreenUpdating off
'
    LR = Range("A" & Rows.Count).End(xlUp).Row                                                          ' Find last row # of data to be used
'
    Column_C_Array = Range("C2:C" & LR)                                                                 ' Store Column C values into 2D, 1 Based array RC
    Column_E_Array = Range("E2:E" & LR)                                                                 ' Store Column E values into 2D, 1 Based array RC
    Column_M_Array = Range("M2:M" & LR)                                                                 ' Store Column E values into 2D, 1 Based array RC
    Columns_D_Thru_F_Array = Range("D2:F" & LR)                                                         ' Store Columns D:F values into 2D, 1 Based array RC
    Columns_F_Thru_H_Array = Range("F2:H" & LR)                                                         ' Store Columns F:H values into 2D, 1 Based array RC
    Columns_N_Thru_P_Array = Range("N2:P" & LR)                                                         ' Store Columns N:P: values into 2D, 1 Based array RC
'
'   Combine columns E:H into E, Delete F:H
    For i = 1 To UBound(Columns_F_Thru_H_Array)                                                         ' Loop through arrays to create column E results
        Column_E_Array(i, 1) = Column_E_Array(i, 1) & ", " & Columns_F_Thru_H_Array(i, 1) & ", " & _
                Columns_F_Thru_H_Array(i, 2) & ", " & Columns_F_Thru_H_Array(i, 3)
    Next                                                                                                ' Loop back
'
    Range("E2:E" & LR) = Column_E_Array                                                                 ' Display results of Column_E_Array to screen
    Range("F1:H1").EntireColumn.Delete                                                                  ' Delete Columns F:H
'
'
'   Combine Columns J:M into J, Delete K:M
    For i = 1 To UBound(Columns_N_Thru_P_Array)                                                         ' Loop through arrays to create column M results
        Column_M_Array(i, 1) = Column_M_Array(i, 1) & ", " & Columns_N_Thru_P_Array(i, 1) & ", " & _
                Columns_N_Thru_P_Array(i, 2) & ", " & Columns_N_Thru_P_Array(i, 3)
    Next                                                                                                ' Loop back
'
    Range("J2:J" & LR) = Column_M_Array                                                                 ' Display results of Column_M_Array to screen
    Range("K1:M1").EntireColumn.Delete                                                                  ' Delete Columns K:M
'
'
    Range("D1:F1").EntireColumn.Insert                                                                  ' Insert Columns D:F
    For i = 1 To UBound(Columns_D_Thru_F_Array)                                                         ' Loop through arrays to create column D:F results
        Columns_D_Thru_F_Array(i, 1) = Column_C_Array(i, 1) & 4
        Columns_D_Thru_F_Array(i, 2) = Column_C_Array(i, 1) & 1
        Columns_D_Thru_F_Array(i, 3) = 201250
    Next                                                                                                ' Loop back
'
    Range("D2:F" & LR) = Columns_D_Thru_F_Array                                                         ' Display results of Columns_D_Thru_F_Array to screen
'
'   Apply Headers to columnns
    Range("D1:F1").Value = Array("Code", "Alt Code", "Extra Code")
    Range("H1") = "Address"
    Range("M1") = "City"
'
'   Autofit columns
    Range("D1:F1").EntireColumn.AutoFit
    Range("H1").EntireColumn.AutoFit
    Range("M1").EntireColumn.AutoFit
'
    Application.ScreenUpdating = True                                                                   ' Turn ScreenUpdating back on
End Sub
@johnnyL thank you so much. I will give this one a shot now. I posted another thread enlisting help to speed up a macro. Would appreciate it if you took a look and told me what you thought.
 

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.

johnnyL

Well-known Member
Joined
Nov 7, 2011
Messages
3,953
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
What is the link to the thread?
 

Coyotex3

Active Member
Joined
Dec 12, 2021
Messages
312
Office Version
  1. 365
  2. 2021
Platform
  1. Windows

Coyotex3

Active Member
Joined
Dec 12, 2021
Messages
312
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
@Coyotex3 you marked that thread as solved already?
Yes I did. Mumps gave me a wonderful reply which technically answered my question of making it more efficient. But someone else mentioned using variants(which I noticed you used on your sub) could make it much quicker and nearly instant apparently. Was hoping you could take a look and tell me what you thought.
 

Forum statistics

Threads
1,181,078
Messages
5,927,966
Members
436,580
Latest member
ajoshi76

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top