I create a code for copy columns between sheets, but I want optimize the code for avoid repeat. What is the best way for optimize the code and avoid the repeations? A for loop?

Sub CopyColumnToWorkbook()

With Worksheets("CES")
    Set SrcRng = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
    Set SrcRng1 = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp))
    Set SrcRng2 = .Range(.Cells(2, "C"), .Cells(.Rows.Count, "C").End(xlUp))
    Set SrcRng3 = .Range(.Cells(2, "D"), .Cells(.Rows.Count, "D").End(xlUp))
    Set SrcRng4 = .Range(.Cells(2, "E"), .Cells(.Rows.Count, "E").End(xlUp))
    Set SrcRng5 = .Range(.Cells(2, "F"), .Cells(.Rows.Count, "F").End(xlUp))
    Set SrcRng6 = .Range(.Cells(2, "G"), .Cells(.Rows.Count, "G").End(xlUp))
    Set SrcRng7 = .Range(.Cells(2, "H"), .Cells(.Rows.Count, "H").End(xlUp))
    Set SrcRng8 = .Range(.Cells(2, "I"), .Cells(.Rows.Count, "I").End(xlUp))
    Set SrcRng9 = .Range(.Cells(2, "J"), .Cells(.Rows.Count, "J").End(xlUp))
    Set SrcRng10 = .Range(.Cells(2, "K"), .Cells(.Rows.Count, "K").End(xlUp))
    Set SrcRng11 = .Range(.Cells(2, "N"), .Cells(.Rows.Count, "N").End(xlUp))
    Set SrcRng12 = .Range(.Cells(2, "O"), .Cells(.Rows.Count, "O").End(xlUp))
    Set SrcRng13 = .Range(.Cells(2, "P"), .Cells(.Rows.Count, "P").End(xlUp))
End With
Worksheets("RESUL").Range("C3").Resize(SrcRng.Rows.Count, 1).Value = SrcRng.Value
Worksheets("RESUL").Range("D3").Resize(SrcRng1.Rows.Count, 1).Value = SrcRng1.Value
Worksheets("RESUL").Range("E3").Resize(SrcRng2.Rows.Count, 1).Value = SrcRng2.Value
Worksheets("RESUL").Range("F3").Resize(SrcRng3.Rows.Count, 1).Value = SrcRng3.Value
Worksheets("RESUL").Range("G3").Resize(SrcRng4.Rows.Count, 1).Value = SrcRng4.Value
Worksheets("RESUL").Range("K3").Resize(SrcRng5.Rows.Count, 1).Value = SrcRng5.Value
Worksheets("RESUL").Range("L3").Resize(SrcRng6.Rows.Count, 1).Value = SrcRng6.Value
Worksheets("RESUL").Range("M3").Resize(SrcRng7.Rows.Count, 1).Value = SrcRng7.Value
Worksheets("RESUL").Range("N3").Resize(SrcRng8.Rows.Count, 1).Value = SrcRng8.Value
Worksheets("RESUL").Range("O3").Resize(SrcRng9.Rows.Count, 1).Value = SrcRng9.Value
Worksheets("RESUL").Range("P3").Resize(SrcRng10.Rows.Count, 1).Value = SrcRng10.Value
Worksheets("RESUL").Range("Q3").Resize(SrcRng11.Rows.Count, 1).Value = SrcRng11.Value
Worksheets("RESUL").Range("R3").Resize(SrcRng12.Rows.Count, 1).Value = SrcRng12.Value
Worksheets("RESUL").Range("S3").Resize(SrcRng13.Rows.Count, 1).Value = SrcRng13.Value
End Sub

CodePudding user response：

Based on the OP's comments you could just copy the values of the columns in question

Sub copyColumns()

    Dim srcWks As Worksheet
    Dim trgWks As Worksheet        
    
    Set srcWks = Worksheets("CES")
    Set trgWks = Worksheets("RESUL")
    
    cp srcWks, trgWks, "A:E", "C:G"
    cp srcWks, trgWks, "F:K", "K:P"
    cp srcWks, trgWks, "N:P", "Q:S"
    
End Sub


Function cp(srcWks As Worksheet, trgWks As Worksheet, col1 As String, col2 As String)
    Dim srcRg As Range
    Dim trgRg As Range
    
    Set srcRg = srcWks.Columns(col1)
    Set srcRg = srcRg.Resize(srcRg.Rows.CountLarge - 1).Offset(1)
    
    Set srcRg = usedRg(srcRg)
    
    Set trgRg = trgWks.Columns(col2)
    Set trgRg = trgRg.Resize(trgRg.Rows.CountLarge - 1).Offset(1)
    Set trgRg = trgRg.Resize(srcRg.Rows.CountLarge, srcRg.Columns.CountLarge)
    trgRg.Value = srcRg.Value

End Function

Function usedRg(rg As Range) As Range
    
    Dim lastRow As Long, lastColumn As Long
   
    lastRow = rg.Cells.Find(What:="*" _
        , Lookat:=xlPart _
        , LookIn:=xlFormulas _
        , searchOrder:=xlByRows _
        , searchDirection:=xlPrevious).Row
   

    lastColumn = rg.Cells.Find(What:="*" _
        , Lookat:=xlPart _
        , LookIn:=xlFormulas _
        , searchOrder:=xlByColumns _
        , searchDirection:=xlPrevious).Column
        
    
    Dim wks As Worksheet
    Set wks = rg.Parent
    With wks
        Set usedRg = Intersect(rg, .Range(.Cells(1, 1), .Cells(lastRow, lastColumn)))
    End With

End Function