Consolidate ever growing VBA

andrewb90

andrewb90

Well-known Member
Joined
Dec 16, 2009
Messages
1,077
Hello!

I Have been trying to find a create way to copy and paste values using VBA, and while it does work perfectly, As I add more cells to my list, the VBA code gets longer and longer. Anyone have any suggestion for how I can consolidate this code? There are multiple other pieces, but they all follow a similar pattern of cell locations, heres the code:
VBA Code: 
Sheets("Large_Set").Select
Range("AC1:AC1").Select
Application.Run "Module2.DUP1C"
Range("D9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AD1:AD1").Select
Application.Run "Module2.DUP1C"
Range("E9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AE1:AE1").Select
Application.Run "Module2.DUP1C"
Range("F9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AF1:AF1").Select
Application.Run "Module2.DUP1C"
Range("G9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AG1:AG1").Select
Application.Run "Module2.DUP1C"
Range("H9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AH1:AH1").Select
Application.Run "Module2.DUP1C"
Range("I9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("Large_Set").Select
Range("AI1:AI1").Select
Application.Run "Module2.DUP1C"
Range("J9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AJ1:AJ1").Select
Application.Run "Module2.DUP1C"
Range("K9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("Large_Set").Select
Range("AK1:AK1").Select
Application.Run "Module2.DUP1C"
Range("L9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AL1:AL1").Select
Application.Run "Module2.DUP1C"
Range("M9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Thank you!
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Sort by date Sort by votes
Hi Drew

I assume you are doing some sort of operation on the selected cell when you run the DUP1C code.

I have left your code as like as possible to yours. This in completely untested, but should work unless you switch selection in the DUPC code):
VBA Code: 
Sub tester()
Dim StartfromCol As Long
Dim EndCol As Long
Dim ToCol As Long
Dim ThisCol As Long

ToCol = 4
StartfromCol = 29
EndCol = 33 ' set this to the column number of the last column to process
For ThisCol = StartfromCol To EndCol

    With Sheets("Large_Set")
        .Cells(1, ThisCol).Select
        Application.Run "Module2.DUP1C"
        .Cells(9, ToCol).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
    End With
    ToCol = ToCol + 1
Next ThisCol

End Sub
 
Upvote 0
Perhaps something like this.
VBA Code: 
Dim rngSrc As Range
Dim rngDst As Range
Dim idx As Long

    Set rngSrc = Sheets("Large_Set").Range("AC1")
    Set rngDst = Sheets("Large_Set").Range("D9")

    For idx = 1 To 9
        Application.Goto rngSrc
        Application.Run "Module2.DUP1C"

        rngDst.PasteSpecial Paste:=xlPasteValues

        Set rngSrc = rngSrc.Offset(1)
   
        Set rngDst = rngDst.Offset(, 1)
    Next idx
 
Upvote 0
Norie said:
Perhaps something like this.
VBA Code: 
Dim rngSrc As Range
Dim rngDst As Range
Dim idx As Long

    Set rngSrc = Sheets("Large_Set").Range("AC1")
    Set rngDst = Sheets("Large_Set").Range("D9")

    For idx = 1 To 9
        Application.Goto rngSrc
        Application.Run "Module2.DUP1C"

        rngDst.PasteSpecial Paste:=xlPasteValues

        Set rngSrc = rngSrc.Offset(1)
  
        Set rngDst = rngDst.Offset(, 1)
    Next idx
Click to expand...
Norie, I'm getting a 1004 error on
VBA Code: 
Application.Goto rngSrc
 
Upvote 0
There's actually a typo in my code, but it shouldn't cause the error you describe.
VBA Code: 
Dim rngSrc As Range
Dim rngDst As Range
Dim idx As Long

    Set rngSrc = Sheets("Large_Set").Range("AC1")
    Set rngDst = Sheets("Large_Set").Range("D9")

    For idx = 1 To 9
        Application.Goto rngSrc
        Application.Run "Module2.DUP1C"

        rngDst.PasteSpecial Paste:=xlPasteValues

        Set rngSrc = rngSrc.Offset(,1)
   
        Set rngDst = rngDst.Offset(, 1)
    Next idx

What does the code DUP1C in Module2 actually do?
 
Upvote 0
jmacleary said:
Hi Drew

I assume you are doing some sort of operation on the selected cell when you run the DUP1C code.

I have left your code as like as possible to yours. This in completely untested, but should work unless you switch selection in the DUPC code):
VBA Code: 
Sub tester()
Dim StartfromCol As Long
Dim EndCol As Long
Dim ToCol As Long
Dim ThisCol As Long

ToCol = 4
StartfromCol = 29
EndCol = 33 ' set this to the column number of the last column to process
For ThisCol = StartfromCol To EndCol

    With Sheets("Large_Set")
        .Cells(1, ThisCol).Select
        Application.Run "Module2.DUP1C"
        .Cells(9, ToCol).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
    End With
    ToCol = ToCol + 1
Next ThisCol

End Sub
Click to expand...
I'm getting a 1004 error on this too, now I'm wondering if I am doing something weird...
 
Upvote 0
Norie said:
There's actually a typo in my code, but it shouldn't cause the error you describe.
VBA Code: 
Dim rngSrc As Range
Dim rngDst As Range
Dim idx As Long

    Set rngSrc = Sheets("Large_Set").Range("AC1")
    Set rngDst = Sheets("Large_Set").Range("D9")

    For idx = 1 To 9
        Application.Goto rngSrc
        Application.Run "Module2.DUP1C"

        rngDst.PasteSpecial Paste:=xlPasteValues

        Set rngSrc = rngSrc.Offset(,1)
  
        Set rngDst = rngDst.Offset(, 1)
    Next idx

What does the code DUP1C in Module2 actually do?
Click to expand...
Here is the entire code:
VBA Code: 
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Run "Module5.destructure"
'individual stats
    Sheets("Large_Set").Range("$A$1:$HW$4001").AutoFilter Field:=1, Criteria1:=BYMODEL.ComboBox3.Value
    
'***********ID #******************
Sheets("Large_Set").Visible = True
Sheets("Large_Set").Select
Range("A1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("G5").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("G5:H5").Select    'optional merge
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
'----------------------------------------------
'***********Year******************
Sheets("Large_Set").Select
Range("D1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("D3").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'----------------------------------------------
'***********make******************
Sheets("Large_Set").Select
Range("B1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("G3").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("F3:H3").Select    'optional merge
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
'----------------------------------------------
'***********model******************
Sheets("Large_Set").Select
Range("C1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("J3").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("I3:K3").Select    'optional merge
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
'----------------------------------------------
'***********Revenue******************
Sheets("Large_Set").Select
Range("AC1:AC1").Select
Application.Run "Module2.DUP1C"
Range("D9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AD1:AD1").Select
Application.Run "Module2.DUP1C"
Range("E9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AE1:AE1").Select
Application.Run "Module2.DUP1C"
Range("F9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AF1:AF1").Select
Application.Run "Module2.DUP1C"
Range("G9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AG1:AG1").Select
Application.Run "Module2.DUP1C"
Range("H9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AH1:AH1").Select
Application.Run "Module2.DUP1C"
Range("I9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("Large_Set").Select
Range("AI1:AI1").Select
Application.Run "Module2.DUP1C"
Range("J9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AJ1:AJ1").Select
Application.Run "Module2.DUP1C"
Range("K9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("Large_Set").Select
Range("AK1:AK1").Select
Application.Run "Module2.DUP1C"
Range("L9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AL1:AL1").Select
Application.Run "Module2.DUP1C"
Range("M9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


Application.DisplayAlerts = True
Application.Run "Module5.structure"
Application.ScreenUpdating = True
'need to reset merged cells prior to restart
End Sub

And here is the DUP1C:
VBA Code: 
Sub DUP1C()
'insert row 1 range select
ActiveCell.Offset(1, 0).Activate
Do Until Selection.EntireRow.Hidden = False
If Selection.EntireRow.Hidden = True Then
ActiveCell.Offset(1, 0).Activate
End If
Loop
ActiveCell.Select
Selection.Copy
    Sheets("CAR_STATS").Select
   ' Range("???").Select
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    '    :=False, Transpose:=False
End Sub
 
Upvote 0
andrewb90 said:
Here is the entire code:
VBA Code: 
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Run "Module5.destructure"
'individual stats
    Sheets("Large_Set").Range("$A$1:$HW$4001").AutoFilter Field:=1, Criteria1:=BYMODEL.ComboBox3.Value
   
'***********ID #******************
Sheets("Large_Set").Visible = True
Sheets("Large_Set").Select
Range("A1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("G5").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("G5:H5").Select    'optional merge
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
'----------------------------------------------
'***********Year******************
Sheets("Large_Set").Select
Range("D1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("D3").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'----------------------------------------------
'***********make******************
Sheets("Large_Set").Select
Range("B1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("G3").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("F3:H3").Select    'optional merge
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
'----------------------------------------------
'***********model******************
Sheets("Large_Set").Select
Range("C1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("J3").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("I3:K3").Select    'optional merge
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
'----------------------------------------------
'***********Revenue******************
Sheets("Large_Set").Select
Range("AC1:AC1").Select
Application.Run "Module2.DUP1C"
Range("D9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AD1:AD1").Select
Application.Run "Module2.DUP1C"
Range("E9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AE1:AE1").Select
Application.Run "Module2.DUP1C"
Range("F9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AF1:AF1").Select
Application.Run "Module2.DUP1C"
Range("G9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AG1:AG1").Select
Application.Run "Module2.DUP1C"
Range("H9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AH1:AH1").Select
Application.Run "Module2.DUP1C"
Range("I9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("Large_Set").Select
Range("AI1:AI1").Select
Application.Run "Module2.DUP1C"
Range("J9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AJ1:AJ1").Select
Application.Run "Module2.DUP1C"
Range("K9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("Large_Set").Select
Range("AK1:AK1").Select
Application.Run "Module2.DUP1C"
Range("L9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AL1:AL1").Select
Application.Run "Module2.DUP1C"
Range("M9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


Application.DisplayAlerts = True
Application.Run "Module5.structure"
Application.ScreenUpdating = True
'need to reset merged cells prior to restart
End Sub

And here is the DUP1C:
VBA Code: 
Sub DUP1C()
'insert row 1 range select
ActiveCell.Offset(1, 0).Activate
Do Until Selection.EntireRow.Hidden = False
If Selection.EntireRow.Hidden = True Then
ActiveCell.Offset(1, 0).Activate
End If
Loop
ActiveCell.Select
Selection.Copy
    Sheets("CAR_STATS").Select
   ' Range("???").Select
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    '    :=False, Transpose:=False
End Sub
Click to expand...
Module2.CopyCar is identical to DUP1C currently.
Module5.structure/destructure unlock and relock the workbook.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Dynamic Address by VBA
Replies
8
Views
152
MikeVol
MikeVol
willow1985
  • Solved
VBA Run-time error 91 - Object variable or With block variable not set when trying to refresh data/Sleep
Replies
4
Views
280
willow1985
willow1985
K
  • Question Question
Increasing row before the macro runs again
Replies
1
Views
211
kbk
K
J
  • Solved
Continuous Copy and paste
2
Replies
10
Views
181
Joe4
Joe4
brent3162
  • Solved
VBA help with increasing row before macro runs again.
Replies
3
Views
363
jolivanes
jolivanes

Forum statistics

Threads
1,223,893
Messages
6,175,241
Members
452,622
Latest member
Laura_PinksBTHFT

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top