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

[HeadAgainstABrickWall]

Cross-posted to StackOverflow: https://stackoverflow.com/posts/71375462/

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

   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!

 

[Peter_SSs]

Cross-posted to StackOverflow.

Can you please post an actual link so helpers here can choose to go and see if it has been solved at StackOverflow before investing time in developing any possible solution here.

 

[HeadAgainstABrickWall]

Solved with assistance at StackOverflow:

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

 

[Peter_SSs]

Can you please post an actual link ..

Thanks for updating the link & for posting the solution.