VBA to automatically copy rows to multiple cells

S

scarletX

New Member
Joined
Mar 4, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
Hello forum!

Currently we have a table of client data with multiple categories of details, something like this:

Client Conditions2.PNG


Our ultimate goal is to translate this file of data into a pivot table, where it counts based on the conditions (let's say from columns AU:BC), to something like this:

PivotTable.PNG


However, we can't seem to figure out an effective way, so we resorted to using VBA so that the script can automatically copy the data from the main table to another sheet and sort them accordingly for the pivot table to extract the data. Ideally, the copied data should appear to be something like this:

Ideal Scenario.PNG


However, on our VBA, it only seemed to work out well on the first portion of our script, it ended up being in this state after we ran the script:

After VBA.PNG


Here is the VBA code that we tried:

VBA Code: 
Sub IntermediateCalc()

    Sheets("Master Data").Range("AU8:AY8").Copy
    Sheets("Working - Domains").Range("B2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        
    DomainBLastRow = Sheets("Working - Domains").Range("B" & Rows.Count).End(xlUp).Row
        
    Sheets("Master Data").Range("AZ8:BC8").Copy
    Sheets("Working - Domains").Range("C" & DomainBLastRow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        
    DomainCLastRow = Sheets("Working - Domains").Range("C" & Rows.Count).End(xlUp).Row
    
    Sheets("Master Data").Range("D8").Copy
    Sheets("Working - Domains").Range("A2:A" & DomainCLastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        
    ClientLastRow = Sheets("Master Data").Range("D" & Rows.Count).End(xlUp).Row
    
    Dim Cell As Range
        For Each Cell In Sheets("Master Data").Range("D9:D11")
            If Cell <> "" Then
                Range(Cell.Offset(0, 43), Cell.Offset(0, 47)).Copy
                Sheets("Working - Domains").Range("B" & DomainCLastRow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=True
                
    VariableBLastRow = Sheets("Working - Domains").Range("B" & Rows.Count).End(xlUp).Row
                
                Range(Cell.Offset(0, 48), Cell.Offset(0, 51)).Copy
                Sheets("Working - Domains").Range("C" & VariableBLastRow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=True
                
    VariableCLastRow = Sheets("Working - Domains").Range("C" & Rows.Count).End(xlUp).Row
                
                'Cell.Copy
                'Sheets("Working - Domains").Range("A" & DomainCLastRow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            Else
                MsgBox "Update Complete"
                
            End If
         Next Cell
          
    
End Sub

It seemed that our script had some issues with detecting the last row, and that is mostly where it got messed up.

Mainly we need help with the VBA, however as I mentioned earlier, the main goal was getting the pivot table, perhaps there is a better alternative, feel free to suggest, we are fine with it too. Any help would be greatly appreciated, do let me know if you need our Excel file as well. Thanks in advance!
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
Try this for now - I'm sure there is a more elegant solution than this, and I'm happy for my code to be superseded once it arrives.

VBA Code: 
Option Explicit
Sub IntermediateCalc()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim c As Range, medR As Range, mntR As Range
    Dim x As Long, y As Long, z As Long, lr As Long
    Dim ar1, ar2
    
    Set ws1 = Sheets("Master Data")
    Set ws2 = Sheets("Working - Domains")
    Application.ScreenUpdating = False
    
    For Each c In ws1.Range("D8", ws1.Cells(Rows.Count, 4).End(xlUp))
        lr = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
        Set medR = ws1.Range(c.Offset(, 2), c.Offset(, 6))
        Set mntR = ws1.Range(c.Offset(, 7), c.Offset(, 11))
        
        x = Application.CountA(medR)
        y = Application.CountA(mntR)
        z = Application.Max(x, y)
        
        ws2.Cells(lr, 1).Resize(z, 1).Value = c
        
        If x > 0 Then
            ar1 = ws1.Range(c.Offset(, 2), c.Offset(, 6)).SpecialCells(xlCellTypeConstants)
            ws2.Cells(lr, 2).Resize(x, 1).Value = Application.Transpose(ar1)
            Else
            GoTo JumpMed
        End If
JumpMed:
        If y > 0 Then
            ar2 = ws1.Range(c.Offset(, 7), c.Offset(, 11)).SpecialCells(xlCellTypeConstants)
            ws2.Cells(lr, 3).Resize(y, 1).Value = Application.Transpose(ar2)
            Else
            GoTo JumpMent
        End If
JumpMent:
    Next c
End Sub
 
Upvote 0
kevin9999 said:
Try this for now - I'm sure there is a more elegant solution than this, and I'm happy for my code to be superseded once it arrives.

VBA Code: 
Option Explicit
Sub IntermediateCalc()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim c As Range, medR As Range, mntR As Range
    Dim x As Long, y As Long, z As Long, lr As Long
    Dim ar1, ar2
   
    Set ws1 = Sheets("Master Data")
    Set ws2 = Sheets("Working - Domains")
    Application.ScreenUpdating = False
   
    For Each c In ws1.Range("D8", ws1.Cells(Rows.Count, 4).End(xlUp))
        lr = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
        Set medR = ws1.Range(c.Offset(, 2), c.Offset(, 6))
        Set mntR = ws1.Range(c.Offset(, 7), c.Offset(, 11))
       
        x = Application.CountA(medR)
        y = Application.CountA(mntR)
        z = Application.Max(x, y)
       
        ws2.Cells(lr, 1).Resize(z, 1).Value = c
       
        If x > 0 Then
            ar1 = ws1.Range(c.Offset(, 2), c.Offset(, 6)).SpecialCells(xlCellTypeConstants)
            ws2.Cells(lr, 2).Resize(x, 1).Value = Application.Transpose(ar1)
            Else
            GoTo JumpMed
        End If
JumpMed:
        If y > 0 Then
            ar2 = ws1.Range(c.Offset(, 7), c.Offset(, 11)).SpecialCells(xlCellTypeConstants)
            ws2.Cells(lr, 3).Resize(y, 1).Value = Application.Transpose(ar2)
            Else
            GoTo JumpMent
        End If
JumpMent:
    Next c
End Sub
Click to expand...
Thanks! It worked, however, the data that was copied over was from a few cells to the right, which was from column F onwards, don't mind if I ask, where is the portion where we can tweak this so that it extracts from column AU onwards?

AfterVBA.PNG


Data table as below:
clientData2.PNG
 
Upvote 0
Sorry, I should have looked closer at your column headings.

Change
VBA Code: 
Set medR = ws1.Range(c.Offset(, 2), c.Offset(, 6))
Set mntR = ws1.Range(c.Offset(, 7), c.Offset(, 11))

To
VBA Code: 
Set medR = ws1.Range(c.Offset(, 43), c.Offset(, 47))
Set mntR = ws1.Range(c.Offset(, 48), c.Offset(, 52))

and change

VBA Code: 
ar1 = ws1.Range(c.Offset(, 2), c.Offset(, 46)).SpecialCells(xlCellTypeConstants)
to
VBA Code: 
ar1 = ws1.Range(c.Offset(, 43), c.Offset(, 47)).SpecialCells(xlCellTypeConstants)

and
VBA Code: 
ar2 = ws1.Range(c.Offset(, 7), c.Offset(, 11)).SpecialCells(xlCellTypeConstants)
to
VBA Code: 
ar2 = ws1.Range(c.Offset(,48), c.Offset(, 52)).SpecialCells(xlCellTypeConstants)
 
Upvote 0
Simpler if I just provide the corrected code (below)

VBA Code: 
Option Explicit
Sub IntermediateCalc()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim c As Range, medR As Range, mntR As Range
    Dim x As Long, y As Long, z As Long, lr As Long
    Dim ar1, ar2
    
    Set ws1 = Sheets("Master Data")
    Set ws2 = Sheets("Working - Domains")
    Application.ScreenUpdating = False
    
    For Each c In ws1.Range("D8", ws1.Cells(Rows.Count, 4).End(xlUp))
        lr = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
        Set medR = ws1.Range(c.Offset(, 43), c.Offset(, 47))
        Set mntR = ws1.Range(c.Offset(, 48), c.Offset(, 52))
        
        x = Application.CountA(medR)
        y = Application.CountA(mntR)
        z = Application.Max(x, y)
        
        ws2.Cells(lr, 1).Resize(z, 1).Value = c
        
        If x > 0 Then
            ar1 = ws1.Range(c.Offset(, 43), c.Offset(, 47)).SpecialCells(xlCellTypeConstants)
            ws2.Cells(lr, 2).Resize(x, 1).Value = Application.Transpose(ar1)
            Else
            GoTo JumpMed
        End If
JumpMed:
        If y > 0 Then
            ar2 = ws1.Range(c.Offset(, 48), c.Offset(, 52)).SpecialCells(xlCellTypeConstants)
            ws2.Cells(lr, 3).Resize(y, 1).Value = Application.Transpose(ar2)
            Else
            GoTo JumpMent
        End If
JumpMent:
    Next c
End Sub
 
Upvote 0
Solution
kevin9999 said:
Simpler if I just provide the corrected code (below)

VBA Code: 
Option Explicit
Sub IntermediateCalc()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim c As Range, medR As Range, mntR As Range
    Dim x As Long, y As Long, z As Long, lr As Long
    Dim ar1, ar2
   
    Set ws1 = Sheets("Master Data")
    Set ws2 = Sheets("Working - Domains")
    Application.ScreenUpdating = False
   
    For Each c In ws1.Range("D8", ws1.Cells(Rows.Count, 4).End(xlUp))
        lr = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
        Set medR = ws1.Range(c.Offset(, 43), c.Offset(, 47))
        Set mntR = ws1.Range(c.Offset(, 48), c.Offset(, 52))
       
        x = Application.CountA(medR)
        y = Application.CountA(mntR)
        z = Application.Max(x, y)
       
        ws2.Cells(lr, 1).Resize(z, 1).Value = c
       
        If x > 0 Then
            ar1 = ws1.Range(c.Offset(, 43), c.Offset(, 47)).SpecialCells(xlCellTypeConstants)
            ws2.Cells(lr, 2).Resize(x, 1).Value = Application.Transpose(ar1)
            Else
            GoTo JumpMed
        End If
JumpMed:
        If y > 0 Then
            ar2 = ws1.Range(c.Offset(, 48), c.Offset(, 52)).SpecialCells(xlCellTypeConstants)
            ws2.Cells(lr, 3).Resize(y, 1).Value = Application.Transpose(ar2)
            Else
            GoTo JumpMent
        End If
JumpMent:
    Next c
End Sub
Click to expand...
OMG that worked like a charm and it's way more organized.. Thank you so much for saving us!
 
Upvote 0
@scarletX there's a possibility the code could crash if you have a client listed with zero conditions listed against them. To eliminate this potential error is easy to do, simply insert the following line of code:

VBA Code: 
If z = 0 Then z = 1

immediately after the line:
VBA Code: 
z = Application.Max(x, y)
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Dynamic Address by VBA
Replies
8
Views
212
MikeVol
MikeVol
C
  • Question Question
How to automatically paste the data from one sheet to another using VBA
Replies
4
Views
291
Alex Blakenburg
A
K
  • Question Question
Increasing row before the macro runs again
Replies
1
Views
230
kbk
K
J
  • Solved
Continuous Copy and paste
2
Replies
10
Views
218
Joe4
Joe4
brent3162
  • Solved
VBA help with increasing row before macro runs again.
Replies
3
Views
378
jolivanes
jolivanes

Forum statistics

Threads
1,224,820
Messages
6,181,155
Members
453,021
Latest member
Justyna P

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