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

[mst3kr]

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
[TABLE="width: 447"]
<tbody>[TR]
[TD]Job[/TD]
[TD]Policy 1[/TD]
[TD]Policy 2[/TD]
[TD]Policy 3[/TD]
[/TR]
[TR]
[TD]Electrician-Journeyman[/TD]
[TD]Required[/TD]
[TD]Required[/TD]
[TD]Required[/TD]
[/TR]
[TR]
[TD]Facilities Maintenance[/TD]
[TD]Required[/TD]
[TD]Required[/TD]
[TD]Required[/TD]
[/TR]
[TR]
[TD]Maintenance Manager[/TD]
[TD]Required[/TD]
[TD]Required[/TD]
[TD]Required[/TD]
[/TR]
[TR]
[TD]QA Manager[/TD]
[TD]N/A[/TD]
[TD]Required[/TD]
[TD]N/A[/TD]
[/TR]
[TR]
[TD]Warehouse Manager[/TD]
[TD]N/A[/TD]
[TD]N/A[/TD]
[TD]Required[/TD]
[/TR]
</tbody>[/TABLE]


Result:
[TABLE="width: 189"]
<tbody>[TR]
[TD]Policy 1[/TD]
[TD]Electrician-Journeyman[/TD]
[/TR]
[TR]
[TD]Policy 1[/TD]
[TD]Facilities Maintenance[/TD]
[/TR]
[TR]
[TD]Policy 1[/TD]
[TD]Maintenance Manager[/TD]
[/TR]
[TR]
[TD]Policy 2[/TD]
[TD]Electrician-Journeyman[/TD]
[/TR]
[TR]
[TD]Policy 2[/TD]
[TD]Facilities Maintenance[/TD]
[/TR]
[TR]
[TD]Policy 2[/TD]
[TD]Maintenance Manager[/TD]
[/TR]
[TR]
[TD]Policy 2[/TD]
[TD]QA Manager[/TD]
[/TR]
[TR]
[TD]Policy 3[/TD]
[TD]Electrician-Journeyman[/TD]
[/TR]
[TR]
[TD]Policy 3[/TD]
[TD]Facilities Maintenance[/TD]
[/TR]
[TR]
[TD]Policy 3[/TD]
[TD]Maintenance Manager[/TD]
[/TR]
[TR]
[TD]Policy 3[/TD]
[TD]Warehouse Manager

[/TD]
[/TR]
</tbody>[/TABLE]

 

[MickG]

Try this for results on sheet2.

[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

 

[mst3kr]

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...

 

[MickG]

You're welcome

 

[mst3kr]

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?

 

[MickG]

Try this:-
This code now returns the string in the intersecting cells (column 3 sheet2) rather than based on the word "Required".

[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

 

[mst3kr]

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!

 

[MickG]

You're welcome