Copy multiple data columns into one column, repeating row labels, dynamic last row and column

[Rowland Hamilton]

Folks,

So far my rewrite takes hiker95's code and copies all same except the data column. I'm getting 2 data type columns (ie the column created with the former column header values). How do I fix this?

Thank you, Rowland Hamilton

Sub ReorgDataV3()
'Option Explicit works above this one (if all other module macros worked,too)
' Modfied from hiker95, 04/19/2011
'
Dim ws1 As Worksheet 'Source worksheet
Dim wsR As Worksheet 'Results worksheet
Dim LR As Long 'Last row
Dim a As Long 'iterated cell in loop
Dim NR As Long 'Next Row
Dim LC As Long 'LC is last column

Application.ScreenUpdating = False
Set ws1 = Worksheets("HC-Stacked")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=ws1).Name = "Results"
Set wsR = Worksheets("Results")
wsR.UsedRange.Clear
wsR.Range("A1:D1") = [{"Location","Home Department","Week","HC"}]
'Replace this: LR = ws1.Cells(Rows.Count, 1).End(xlUp).Row
               LR = ws1.Range(Rows.Count, 2).End(xlUp).Row
'Added Last column derivation
               LC = ws1.Range(1, Columns.Count).End(xlToLeft).Column
For a = 2 To LR Step 1
  NR = wsR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
  'replace: wsR.Range("A" & NR).Resize(12, 2).Value = ws1.Range("A" & a).Resize(, 2).Value
        wsR.Range("A" & NR).Resize(LC - 2, 2).Value = ws1.Range("A" & a).Resize(, 2).Value
  
  'replace: wsR.Range("C" & NR).Resize(12).Value = Application.Transpose(ws1.Range("C1:N1").Value)
        wsR.Range("C" & NR).Resize(LC - 2).Value = Application.Transpose(ws1.Range(Cells(1, 3), Cells(1, LC)).Value)
  
  'replace: wsR.Range("D" & NR).Resize(12).Value = Application.Transpose(ws1.Range("C" & a & ":N" & a).Value)
        wsR.Range("D" & NR).Resize(LC - 2).Value = Application.Transpose(ws1.Range(Cells(a, 3), Cells(1, LC)).Value)
Next a
wsR.UsedRange.Columns.AutoFit
wsR.Activate
Application.ScreenUpdating = True
End Sub

Sub ReorgDataV1()
'Option Explicit works above this one (if all other module macros worked,too)
' hiker95, 04/19/2011

Dim ws1 As Worksheet, wsR As Worksheet
Dim LR As Long, a As Long, NR As Long
Application.ScreenUpdating = False
Set ws1 = Worksheets("HC-Stacked")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=ws1).Name = "Results"
Set wsR = Worksheets("Results")
wsR.UsedRange.Clear
wsR.Range("A1:D1") = [{"Location","Home Department","Week","HC"}]
LR = ws1.Cells(Rows.Count, 1).End(xlUp).Row

For a = 2 To LR Step 1
  NR = wsR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
  wsR.Range("A" & NR).Resize(12, 2).Value = ws1.Range("A" & a).Resize(, 2).Value
  wsR.Range("C" & NR).Resize(12).Value = Application.Transpose(ws1.Range("C1:N1").Value)
  wsR.Range("D" & NR).Resize(12).Value = Application.Transpose(ws1.Range("C" & a & ":N" & a).Value)
Next a
wsR.UsedRange.Columns.AutoFit
wsR.Activate
Application.ScreenUpdating = True
End Sub

 

[Rowland Hamilton]

Correction: I had to use "Cells" not "Range" for last row and column codes:

'Replace this: LR = ws1.Cells(Rows.Count, 1).End(xlUp).Row
               LR = ws1.Cells(Rows.Count, 2).End(xlUp).Row
'Added Last column derivation
               LC = ws1.Cells(1, Columns.Count).End(xlToLeft).Column]

 

[Rowland Hamilton]

Folks,

OK, I figured it out. First, I referenced the 1st row instead of row "a". Also, I referenced cells with no parent. Corrected code below.:

Sub ReorgDataV3()
'Option Explicit works above this one (if all other module macros worked,too)
' hiker95, 04/19/2011
' [URL="http://www.mrexcel.com/forum/showthread.php?t=544487"]Excel macro - change column data to multiple rows[/URL]
Dim ws1 As Worksheet 'Source worksheet
Dim wsR As Worksheet 'Results worksheet
Dim LR As Long 'Last row
Dim a As Long 'iterated cell in loop
Dim NR As Long 'Next Row
Dim LC As Long 'LC is last column
Application.ScreenUpdating = False
Set ws1 = Worksheets("HC-Stacked")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=ws1).Name = "Results"
Set wsR = Worksheets("Results")
wsR.UsedRange.Clear
wsR.Range("A1:D1") = [{"Location","Home Department","Week","HC"}]
'Replace this: LR = ws1.Cells(Rows.Count, 1).End(xlUp).Row
               LR = ws1.Cells(Rows.Count, 2).End(xlUp).Row
'Added Last column derivation
               LC = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
For a = 2 To LR Step 1
    '*Finds last populated row in results tab and goes to row below
  NR = wsR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
  
'*Make current row of Source tab labels in Columns A & B = copy to next # of rows in Results tab = # data columns
  'replace: wsR.Range("A" & NR).Resize(12, 2).Value = ws1.Range("A" & a).Resize(, 2).Value
        wsR.Range("A" & NR).Resize(LC - 2, 2).Value = ws1.Range("A" & a).Resize(, 2).Value
        
'*Transposes Source data headers to Results column C
  'replace: wsR.Range("C" & NR).Resize(12).Value = Application.Transpose(ws1.Range("C1:N1").Value)
        wsR.Range("C" & NR).Resize(LC - 2).Value = Application.Transpose(ws1.Range(ws1.Cells(1, 3), ws1.Cells(1, LC)).Value)
'*Transposes current Source row's data to Results column D
  'replace: wsR.Range("D" & NR).Resize(12).Value = Application.Transpose(ws1.Range("C" & a & ":N" & a).Value)
        wsR.Range("D" & NR).Resize(LC - 2).Value = Application.Transpose(ws1.Range(ws1.Cells(a, 3), ws1.Cells(a, LC)).Value)
Next a
wsR.UsedRange.Columns.AutoFit
wsR.Activate
Application.ScreenUpdating = True
End Sub

 

[Rowland Hamilton]

Folks,

How can I pause the For Step Next loop on the 2nd to last iteration then resume it from there with step through? or slow down between loops so I can pause? (investigating why Its skipping the GRAND TOTALS data but getting the one row of data beneath it, the last row of data which is a sub-set of the other data).

THANK YOU, Rowland Hamilton

 

[Rowland Hamilton]

Folks,

Ah, my error was my Grand total and Additional row below that does not have data in column A so when Next Row is determined, I am overwriting the GRAND TOTAL rows with the data below it.

Why is it so hard to type in this forum now? Anyway, I used

Application.Wait (Now() + TimeValue("0:00:5"))[CODE] but I couldn't stop it before it finished using the vbe pause button. I'll try Ctrl +Break next time when I find the key. Also reading Break won't work without DoEvents? Also, I have no break key on this computer so I have to go to Start>type "On">shoose "On Screen Keyboard">Now can click ."CTRL+Pause"?

 

[Rowland Hamilton]

So, now UsedRange not recognized on this computer after I already ran the macro 3 or 4 times? Just broke after I changed Next Row to determine off of Column B instead of Column A...
Breaks on

 wsR.UsedRange.Clear

Sub ReorgDataV3()
'Option Explicit works above this one (if all other module macros worked,too)
' hiker95, 04/19/2011
' [URL="http://www.mrexcel.com/forum/showthread.php?t=544487"]Excel macro - change column data to multiple rows[/URL]
Dim ws1 As Worksheet 'Source worksheet
Dim wsR As Worksheet 'Results worksheet
Dim LR As Long 'Last row
Dim a As Long 'iterated cell in loop
Dim NR As Long 'Next Row
Dim LC As Long 'LC is last column

Application.ScreenUpdating = False
Set ws1 = Worksheets("HC-Stacked")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=ws1).Name = "Results"
Set wsR = Worksheets("Results")
wsR.UsedRange.Clear
wsR.Range("A1:D1") = [{"Location","Home Department","Week","HC"}]
'Replace this: LR = ws1.Cells(Rows.Count, 1).End(xlUp).Row
               LR = ws1.Cells(Rows.Count, 2).End(xlUp).Row
'Added Last column derivation
               LC = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
For a = 2 To LR Step 1
    '*Finds last populated row in results tab and goes to row below
  NR = wsR.Range("B" & Rows.Count).End(xlUp).Offset(1).Row
  
'*Make current row of Source tab labels in Columns A & B = copy to next # of rows in Results tab = # data columns
  'replace: wsR.Range("A" & NR).Resize(12, 2).Value = ws1.Range("A" & a).Resize(, 2).Value
        wsR.Range("A" & NR).Resize(LC - 2, 2).Value = ws1.Range("A" & a).Resize(, 2).Value
        
'*Transposes Source data headers to Results column C
  'replace: wsR.Range("C" & NR).Resize(12).Value = Application.Transpose(ws1.Range("C1:N1").Value)
        wsR.Range("C" & NR).Resize(LC - 2).Value = Application.Transpose(ws1.Range(ws1.Cells(1, 3), ws1.Cells(1, LC)).Value)
'*Transposes current Source row's data to Results column D
  'replace: wsR.Range("D" & NR).Resize(12).Value = Application.Transpose(ws1.Range("C" & a & ":N" & a).Value)
        wsR.Range("D" & NR).Resize(LC - 2).Value = Application.Transpose(ws1.Range(ws1.Cells(a, 3), ws1.Cells(a, LC)).Value)
        
    'Application.Wait (Now() + TimeValue("0:00:5"))
Next a
wsR.UsedRange.Columns.AutoFit
wsR.Activate
Application.ScreenUpdating = True
End Sub

 

[Rowland Hamilton]

Folks,

Some how My cursor was highlighting the sheet name at the time as if to rename it. Once I took it off the tab name, MACRO ran with no errors.

Thanks,
Rowland Hamilton