VBA Loop Copy & Vertical Paste 2 data points based on [3rd] Criteria

mst3kr

New Member
Joined
Apr 15, 2013
Messages
46
Office Version
  1. 2019
  2. 2010
  3. 2007
Platform
  1. Windows
I have some data that I need to flip and copy & paste vertically based on the value at the intersection of a row & column. Below is the data as it is currently & how I need it to look. The result is based on where the policy is marked as 'Required' for that job & policy. I have tried various, inelegant formula options, and some VBA but cannot get either to work. I need it to loop through roughly 400 rows and 125 columns. I've looked thru the forums to see if something similar was asked/posted but came up empty. So, any help would be greatly appreciated!


Current:
A1 B1 C1 D1
JobPolicy 1Policy 2Policy 3
Electrician-JourneymanRequiredRequiredRequired
Facilities MaintenanceRequiredRequiredRequired
Maintenance ManagerRequiredRequiredRequired
QA ManagerN/ARequiredN/A
Warehouse ManagerN/AN/ARequired

<tbody>
</tbody>


Result:
Policy 1Electrician-Journeyman
Policy 1Facilities Maintenance
Policy 1Maintenance Manager
Policy 2Electrician-Journeyman
Policy 2Facilities Maintenance
Policy 2Maintenance Manager
Policy 2QA Manager
Policy 3Electrician-Journeyman
Policy 3Facilities Maintenance
Policy 3Maintenance Manager
Policy 3Warehouse Manager


<tbody>
</tbody>
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Try this for results on sheet2.
Code:
[COLOR="Navy"]Sub[/COLOR] MG26Jun08
[COLOR="Navy"]Dim[/COLOR] ray [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
ray = Cells(1).CurrentRegion
ReDim nray(1 To UBound(ray, 1) * UBound(ray, 2), 1 To 2)
nray(1, 1) = "Policy#": nray(1, 2) = "Job"
c = 1
[COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(ray, 2)
    [COLOR="Navy"]For[/COLOR] n = 2 To UBound(ray, 1)
       [COLOR="Navy"]If[/COLOR] ray(n, Ac) = "Required" [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        nray(c, 1) = ray(1, Ac)
        nray(c, 2) = ray(n, 1)
       [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 2)
    .Value = nray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Thanks so much Mick! This works perfectly!! I've never worked with UBound commands before. I guess I have another bit of VBA code to get to know... :)
 
Upvote 0
Hi Mick. I have an additional question. I have been asked to actually to include the verbiage "Required" or "N/A", where the criteria intersect, in my final output. Thus, the data would look like:

Policy 1 Electrician-Journeyman Required
Policy 3 QA Manager N/A

I've tried to manipulate the code by adding an additional nray and/or adding an additional IF statement to include the 3rd criteria but haven't been able to get it to work. How can I change the coding to copy & paste that 3rd criteria?
 
Upvote 0
Try this:-
This code now returns the string in the intersecting cells (column 3 sheet2) rather than based on the word "Required".
Code:
[COLOR="Navy"]Sub[/COLOR] MG27Jun31
[COLOR="Navy"]Dim[/COLOR] ray [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
ray = Cells(1).CurrentRegion
ReDim nray(1 To UBound(ray, 1) * UBound(ray, 2), 1 To 3)
nray(1, 1) = "Policy#": nray(1, 2) = "Job": nray(1, 3) = "Criteria"
c = 1
[COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(ray, 2)
    [COLOR="Navy"]For[/COLOR] n = 2 To UBound(ray, 1)
        c = c + 1
        nray(c, 1) = ray(1, Ac)
        nray(c, 2) = ray(n, 1)
        nray(c, 3) = ray(n, Ac)
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 3)
    .Value = nray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Works perfectly! Thanks Mick! When I'd tried revising the code, it matched yours except for the third nray components, (ray(N, Ac). I kept thinking it needed to be either n, 2 or n, 3. VBA has never been my strong suit but over the years I've learned quite a bit but clearly have more to go! Thanks again! :)
 
Upvote 0

Forum statistics

Threads
1,213,484
Messages
6,113,923
Members
448,533
Latest member
thietbibeboiwasaco

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