Loop whole-of-column code through non-contiguous columns?

Joined
Jan 30, 2022
Messages
30
Office Version
  1. 365
Platform
  1. Windows
Cross-posted to StackOverflow: https://stackoverflow.com/posts/71375462/

I have written the following code to fix inconsistent date formats:

VBA Code:
   Dim Rng As Range

    Dim CopyName As String

    Set Rng = Range("B:B")

        With Rng

            CopyName = Rng(1).Value

            .Range(.Cells(1, 0), .Cells(1, 0)).Value = CopyName & "_OLD"

            .Offset(0, 1).Resize(, 5).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

            .Offset(0, 1).Resize(, 3).NumberFormat = "0"

            .Offset(0, 4).NumberFormat = "MMM"

            .Offset(0, 5).NumberFormat = "DD-MMM-YYYY"

            .TextToColumns Destination:=Rng.Offset(0, 1), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True

            .Range(.Cells(1, 4), .Cells(1, 4)).Value = CopyName & "_MONTH"

            .Range(.Cells(1, 5), .Cells(1, 5)).Value = CopyName

            .Range(.Cells(2, 4), .Cells(2, 4)).Formula2R1C1 = "=IF(CELL(""Format"", [@[" & Rng(1) & "]])=""D1"", TEXT([@[" & Rng(1).Offset(0, 2) & "]]*29,""mmm""), TEXT([@[" & Rng(1).Offset(0, 1) & "]]*29, ""mmm""))"

            .Resize(, 5).Copy

            .Resize(, 5).PasteSpecial Paste:=xlPasteValues

            .Range(.Cells(2, 5), .Cells(2, 5)).Formula2R1C1 = "=IF(CELL(""Format"", [@[" & Rng(1) & "]])=""D1"", [@[" & Rng(1).Offset(0, 1) & "]]&""-""&TEXT([@[" & Rng(1).Offset(0, 4) & "]], """")&""-""&[@[" & Rng(1).Offset(0, 3) & "]], [@[" & Rng(1).Offset(0, 2) & "]]&""-""&TEXT([@[" & Rng(1).Offset(0, 4) & "]], """")&""-""&[@[" & Rng(1).Offset(0, 3) & "]])"

            .Resize(, 6).Copy

            .Resize(, 6).PasteSpecial Paste:=xlPasteValues

            .Resize(, 5).DELETE

        End With

I am now trying to figure out how to loop this through non-contiguous columns, e.g. B, C, D, and F. I have tried a few ways that kept throwing errors, e.g. for each colx in range, but can't figure it out while keeping rng as the specific column the code is acting on.

Any advice welcome. Also, if anyone can advise how to speed this up (the formulas bottleneck everything, hence the duplicate copy paste values), it would also be appreciated!
 
Last edited:

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Solved with assistance at StackOverflow:

VBA Code:
Dim cols As Range

    Dim Rng As Range

 

    Dim CopyName As String

    Dim col

   

    

    For Each col In Array("B", "C", "D", "F")

    Set Rng = ActiveSheet.Columns(col)

   

        With Rng

            CopyName = Rng.Cells(1).Value

            .Cells(1).Value = CopyName & "_OLD"

            .Offset(0, 1).Resize(, 5).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

            .Offset(0, 1).Resize(, 3).NumberFormat = "0"

            .Offset(0, 4).NumberFormat = "MMM"

            .Offset(0, 5).NumberFormat = "DD-MMM-YYYY"

            .TextToColumns Destination:=Rng.Offset(0, 1), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True

            .Cells(1).Offset(, 4).Value = CopyName & "_MONTH"

            .Cells(2).Offset(, 4).Formula2R1C1 = "=IF([@[" & Rng.Cells(1) & "]]="""", """", IF(CELL(""Format"", [@[" & Rng.Cells(1) & "]])=""D1"", TEXT([@[" & Rng.Cells(1).Offset(0, 2) & "]]*29,""mmm""), TEXT([@[" & Rng.Cells(1).Offset(0, 1) & "]]*29, ""mmm"")))"

            .Offset(0, 4).Copy

            .Offset(0, 4).PasteSpecial Paste:=xlPasteValues

            .Cells(1).Offset(, 5).Value = CopyName

            .Cells(2).Offset(, 5).Formula2R1C1 = "=IF([@[" & Rng.Cells(1) & "]]="""", """", IF(CELL(""Format"", [@[" & Rng.Cells(1) & "]])=""D1"", [@[" & Rng.Cells(1).Offset(0, 1) & "]]&""-""&TEXT([@[" & Rng.Cells(1).Offset(0, 4) & "]], """")&""-""&[@[" & Rng.Cells(1).Offset(0, 3) & "]], [@[" & Rng.Cells(1).Offset(0, 2) & "]]&""-""&TEXT([@[" & Rng.Cells(1).Offset(0, 4) & "]], """")&""-""&[@[" & Rng.Cells(1).Offset(0, 3) & "]]))"

            .Offset(0, 5).Copy

            .Offset(0, 5).PasteSpecial Paste:=xlPasteValues

            .Resize(, 5).DELETE

        End With

       

    Next
 
Upvote 0
Solution

Forum statistics

Threads
1,222,146
Messages
6,164,231
Members
451,881
Latest member
John kaiser

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
Back
Top