Help with condensing a lot of copying/pasting...

[gab1972]

I'm working on a spreadsheet that requires pulling information from
one sheet (that is an input form for users) and then puts all the
information on one line for transfer to MS Access. I have about 24
rows of info in columns A, C, E, G. I need to get that information
into one row. Below is the only way I know how. Can anyone help me
condense this to something simpler? Thanks in advance.

'Permit.Lifecycle information
Sheets("AppendPermit").Range("A30:A54").Copy
Sheets("Appending").Range("A5").PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("AppendPermit").Range("C30:C54").Copy
Sheets("Appending").Range("A6").PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("AppendPermit").Range("E30:E54").Copy
Sheets("Appending").Range("A7").PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("AppendPermit").Range("G30:G54").Copy
Sheets("Appending").Range("A8").PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("A5:A8").Copy
Sheets("Appending").Range("AN2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("B5:B8").Copy
Sheets("Appending").Range("AR2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("C5:C8").Copy
Sheets("Appending").Range("AV2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("D5:E8").Copy
Sheets("Appending").Range("AZ2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("E5:E8").Copy
Sheets("Appending").Range("BD2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("F5:G8").Copy
Sheets("Appending").Range("BH2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("G5:H8").Copy
Sheets("Appending").Range("BL2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("H5:H8").Copy
Sheets("Appending").Range("BP2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("I5:I8").Copy
Sheets("Appending").Range("BT2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("J5:J8").Copy
Sheets("Appending").Range("BX2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("K5:K8").Copy
Sheets("Appending").Range("CB2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("L5:L8").Copy
Sheets("Appending").Range("CF2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("M5:M8").Copy
Sheets("Appending").Range("CJ2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("N5:N8").Copy
Sheets("Appending").Range("CN2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("O5:O8").Copy
Sheets("Appending").Range("CR2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("P58").Copy
Sheets("Appending").Range("CV2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("Q5:Q8").Copy
Sheets("Appending").Range("CZ2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("R5:R8").Copy
Sheets("Appending").Range("DD2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("S5:S8").Copy
Sheets("Appending").Range("DH2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("T5:T8").Copy
Sheets("Appending").Range("DL2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("U5:U8").Copy
Sheets("Appending").Range("DP2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("V5:V8").Copy
Sheets("Appending").Range("DT2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("W5:W8").Copy
Sheets("Appending").Range("DX2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("X5:X8").Copy
Sheets("Appending").Range("EB2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Appending").Range("Y5:Y8").Copy
Sheets("Appending").Range("EF2").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True

 

[john]

You could use a loop to cycle through the ranges to reduce amount of code.

I had a quick play with following but not fully tested & approach could be
improved with more time. Hopefully though, will give you some ideas.


Sub CopyData()
Dim AppPerWS As Worksheet
Dim AppendWS As Worksheet
Dim PasteRange

Set AppPerWS = Worksheets("AppendPermit")
Set AppendWS = Worksheets("Appending")

PasteRange = Array("AN2", "AR2", "AV2", "AZ2", _
"BD2", "BH2", "BL2", "BP2", "BT2", "BX2", _
"CB2", "CF2", "CJ2", "CN2", "CR2", "CV2", "CZ2", _
"DD2", "DH2", "DL2", "DP2", "DT2", "DX2", _
"EB2", "EF2")

'Permit.Lifecycle information

Application.ScreenUpdating = False

On Error Resume Next

i = 5
For col = 1 To 7 Step 2

AppPerWS.Range(Cells(30, col), Cells(54, col)).Copy
AppendWS.Range("A" & i).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True
Application.CutCopyMode = False

i = i + 1

Next col


For col = 1 To 25

AppendWS.Range(Cells(5, col), Cells(8, col)).Copy
AppendWS.Range(PasteRange(col - 1)).PasteSpecial
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True

Application.CutCopyMode = False

Next col

Application.ScreenUpdating = True
End Sub

 

[gab1972]

You could use a loop to cycle through the ranges to reduce amount of code..

I had a quick play with following but not fully tested & approach could be
improved with more time. Hopefully though, will give you some ideas.

Sub CopyData()
    Dim AppPerWS As Worksheet
    Dim AppendWS As Worksheet
    Dim PasteRange

    Set AppPerWS = Worksheets("AppendPermit")
    Set AppendWS = Worksheets("Appending")

    PasteRange = Array("AN2", "AR2", "AV2", "AZ2", _
                       "BD2", "BH2", "BL2", "BP2", "BT2", "BX2", _
                       "CB2", "CF2", "CJ2", "CN2", "CR2", "CV2", "CZ2", _
                       "DD2", "DH2", "DL2", "DP2", "DT2", "DX2", _
                       "EB2", "EF2")

    'Permit.Lifecycle information

    Application.ScreenUpdating = False

    On Error Resume Next

    i = 5
    For col = 1 To 7 Step 2

        AppPerWS.Range(Cells(30, col), Cells(54, col)).Copy
        AppendWS.Range("A" & i).PasteSpecial Paste:=xlPasteValues, _
                                             Operation:=xlNone, _
                                             SkipBlanks:=False, _
                                             Transpose:=True
        Application.CutCopyMode = False

        i = i + 1

    Next col

    For col = 1 To 25

        AppendWS.Range(Cells(5, col), Cells(8, col)).Copy
        AppendWS.Range(PasteRange(col - 1)).PasteSpecial
Paste:=xlPasteValues, _
                                                         Operation:=xlNone, _
                                                         SkipBlanks:=False, _
                                                         Transpose:=True

        Application.CutCopyMode = False

    Next col

    Application.ScreenUpdating = True
End Sub

Out of curiosity...what is the (col - 1) portion for? I used this in
a sample/testing sheet and it doesn't paste the first set (i.e. A5:A8)

 

[john]

(col - 1) value is used to select the correct element of the Array which
starts at 0.

I am about to leave my office but as a quick suggestion try adding

AppendWS.Activate

above the second FOR Loop.

You should not really need to do this but have not got time to figure out
what error I have made.

 

[john]

put a bit of overtime in & discovered I had not fully qualified the Cells
ranges which was giving the error.

Hopefully, this will work now.

Sub CopyData()
Dim AppPerWS As Worksheet
Dim AppendWS As Worksheet
Dim PasteRange

Set AppPerWS = Worksheets("AppendPermit")
Set AppendWS = Worksheets("Appending")

PasteRange = Array("AN2", "AR2", "AV2", "AZ2", _
"BD2", "BH2", "BL2", "BP2", "BT2", "BX2", _
"CB2", "CF2", "CJ2", "CN2", "CR2", "CV2", "CZ2", _
"DD2", "DH2", "DL2", "DP2", "DT2", "DX2", _
"EB2", "EF2")

'Permit.Lifecycle information

Application.ScreenUpdating = False

On Error Resume Next

i = 5

For col = 1 To 7 Step 2

AppPerWS.Range(AppPerWS.Cells(30, col), AppPerWS.Cells(54, col)).Copy


AppendWS.Range("A" & i).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True
Application.CutCopyMode = False

i = i + 1

Next col


For col = 1 To 25

AppendWS.Range(AppendWS.Cells(5, col), AppendWS.Cells(8, col)).Copy

AppendWS.Range(PasteRange(col - 1)).PasteSpecial
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True

Application.CutCopyMode = False


Next col

Application.ScreenUpdating = True
End Sub