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

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!

CodePudding user response：

Something like this would loop over different columns:

Sub Test()

    Dim CopyName As String
    Dim col
    
    For Each col In Array("B", "C", "D", "F")
        With ActiveSheet.Columns(col)

            CopyName = .Cells(1).Value 'edited

            .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:=.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, 4).Value = CopyName & "_MONTH"
            .Cells(1, 5).Value = CopyName
            .Cells(2, 4).Formula2R1C1 = "=IF(CELL(""Format"", [@[" & .Cells(1) & "]])=""D1"", TEXT([@[" & .Cells(1).Offset(0, 2) & "]]*29,""mmm""), TEXT([@[" & .Cells(1).Offset(0, 1) & "]]*29, ""mmm""))"

            .Resize(, 5).Value = .Resize(, 5).Value 'no need for copy/paste
            .Cells(2, 5).Formula2R1C1 = "=IF(CELL(""Format"", [@[" & .Cells(1) & "]])=""D1"", ""[@[" & .Cells(1).Offset(0, 1) & "]]&""-""&TEXT([@[" & .Cells(1).Offset(0, 4) & "]], """")&""-""&[@[" & .Cells(1).Offset(0, 3) & "]], [@[" & .Cells(1).Offset(0, 2) & "]]&""-""&TEXT([@[" & .Cells(1).Offset(0, 4) & "]], """")&""-""&[@[" & .Cells(1).Offset(0, 3) & "]])"

            .Resize(, 6).Value = .Resize(, 6).Value
            .Resize(, 5).Delete

        End With
    Next col

End Sub

I don't follow your formulas, so if you could explain what you're doing here then someone might suggest a different approach.

CodePudding user response：

Solution found with great assistance from @Tim:

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