vba to copy every singe cell using WITH

Hey guys,

I adapted this code, I am trying to copy every single cell as is for the stipulated column, but it only copies rows in that column where there is a rank in column A. You can run my macro to see the copy over issue.

attached is my code and excel.
the 3rd tab shows what it should look like when copying columns A and C into dws from sws column A & B. if you make this work, il adapt it for the rest of the columns.

It also needs to paste in the Funds sheet from row 3, not row 2.

Sub fundscopyover()

Dim WIP As Worksheet, Funds As Worksheet

Dim sws As Worksheet, dws As Worksheet
Dim slr As Long, dlr As Long, r As Long
Dim sRng As Range, sCell As Range

With Application
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set sws = Sheets("WIP")
Set dws = Sheets("Funds")
slr = sws.UsedRange.Rows.Count

sws.AutoFilterMode = False
With sws
        Set sRng = sws.Range("B3:B" & slr)
        For Each sCell In sRng
            r = sCell.Row
            dlr = dws.Cells(Rows.Count, 1).End(xlUp).Row + 1
            dws.Range("A" & dlr).Value = sws.Range("A" & r).Value
            dws.Range("B" & dlr).Value = sws.Range("BB" & r).Value
            dws.Range("C" & dlr).Value = sws.Range("B" & r).Value
            dws.Range("D" & dlr).Value = sws.Range("I" & r).Value
            dws.Range("G" & dlr).Value = sws.Range("F" & r).Value
            dws.Range("H" & dlr).Value = sws.Range("G" & r).Value
            dws.Range("I" & dlr).Value = sws.Range("H" & r).Value
            dws.Range("J" & dlr).Value = sws.Range("M" & r).Value
            dws.Range("L" & dlr).Value = sws.Range("Q" & r).Value
            dws.Range("M" & dlr).Value = sws.Range("U" & r).Value
            dws.Range("N" & dlr).Value = sws.Range("Y" & r).Value
            dws.Range("O" & dlr).Value = sws.Range("AC" & r).Value
            dws.Range("P" & dlr).Value = sws.Range("AG" & r).Value
            dws.Range("Q" & dlr).Value = sws.Range("AK" & r).Value
            dws.Range("R" & dlr).Value = sws.Range("AZ" & r).Value
            dws.Range("S" & dlr).Value = sws.Range("AT" & r).Value
            dws.Range("T" & dlr).Value = sws.Range("AU" & r).Value
            dws.Range("U" & dlr).Value = sws.Range("AO" & r).Value
            dws.Range("V" & dlr).Value = sws.Range("AP" & r).Value
            dws.Range("W" & dlr).Value = sws.Range("AR" & r).Value
            dws.Range("X" & dlr).Value = sws.Range("AV" & r).Value
            dws.Range("Y" & dlr).Value = sws.Range("AW" & r).Value
            dws.Range("Z" & dlr).Value = sws.Range("AX" & r).Value
            dws.Range("AA" & dlr).Value = sws.Range("AN" & r).Value
            dws.Range("AB" & dlr).Value = sws.Range("D" & r).Value
        Next sCell
    
End With


With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
End With


End Sub

Thanks guys

Originally Posted by Richard Buttrey

Surely all you neeed is:

Sub CopyFunds()
   Sheet2.Range("A1").CurrentRegion.Offset(2, 0).Resize(, 2).Copy Sheet13.Range("A3")
End Sub

Hey Richard

I tried this but i see that it copies column A & B, this is fine.

But il need to copy specific single columns that are not next to each other.

I will try this and let you know the outcome.

Sorry been busy, but still need this.

Does this help?

Sub Muktar888z()
Dim x As Long, ws As Worksheet
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With
Set ws = Sheets("WIP")
With ws
    x = .Range("B" & Rows.Count).End(3).row
        .Range("A3:A" & x).Copy Sheets("Funds").Range("A3")
        .Range("B3:B" & x).Copy Sheets("Funds").Range("C3")
End With
With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With
End Sub