Converting columns to rows

[CJW_14]

Hi All,

I have the following code I was able to hack to suit my needs. It works great but with my limited knowledge im having problems sorting out a couple of issue's

1. I want to specify a range (variable number of rows but the last column is R) there is data in the subsequent columns Im not interested in)
2. When blank cells occur, the code appears to stop and not continue onto the next cell.

Sub test

Dim ws As Worksheet, nws As Worksheet
Dim i As Long, j As Long, c As Long
Set ws = ActiveSheet
Set nws = Worksheets.Add
nws.Name = "Forms_filled"
i = 0
c = 0

nws.Range("A1").Value = "unit ID"
nws.Range("B1").Value = "unit Name"
nws.Range("C1").Value = "type"
nws.Range("D1").Value = "Yes/No"

Do While ws.Cells(2 + i, 1).Value <> ""
    j = 0
    Do While ws.Cells(2, 3 + j).Value <> ""

        nws.Cells(2 + c, 1).Value = ws.Cells(2 + i, 1).Value ' unit ID
        nws.Cells(2 + c, 2).Value = ws.Cells(2 + i, 2).Value ' Unit name
                
        nws.Cells(2 + c, 3).Value = ws.Cells(1, 3 + j).Value 'type
                
        nws.Cells(2 + c, 4).Value = ws.Cells(2 + i, 3 + j).Value 'Yes/No etc
 
        c = c + 1
        j = j + 1
    Loop
    i = i + 1
Loop

Cells.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes

End Sub

Any help would be greatly appreciated

[offthelip]

try this which detects the last row with data on the active sheet and loops from 1 to that number and then copies 10 columns (A to J)

Sub test()

Dim ws As Worksheet, nws As Worksheet
Dim i As Long, j As Long, c As Long
Set ws = ActiveSheet
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set nws = Worksheets.Add
nws.Name = "Forms_filled"




nws.Range("A1").Value = "unit ID"
nws.Range("B1").Value = "unit Name"
nws.Range("C1").Value = "type"
nws.Range("D1").Value = "Yes/No"


For i = 1 To lastrow
    
    For j = 1 To 10


        nws.Cells(1 + i, 1).Value = ws.Cells(2 + i, 1).Value ' unit ID
        nws.Cells(1 + i, 2).Value = ws.Cells(2 + i, 2).Value ' Unit name
                
        nws.Cells(1 + i, 3).Value = ws.Cells(1, 3 + j).Value 'type
                
        nws.Cells(1 + i, 4).Value = ws.Cells(2 + i, 3 + j).Value 'Yes/No etc
 


      Next j
Next i
Cells.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes


End Sub

[snb]

Don't use code you do not fully understand.

Especially not if it's ridiculous code:

With sheets.Add
  .name = "Forms_filled"
  .Range("A1:D1") = Array("unit ID","unit Name","type","Yes/No")
End with

Use Arrays: http://www.snb-vba.eu/VBA_Arrays_en.html

[p45cal]

Difficult to test without a workbook, but try:

Sub test()
Dim ws As Worksheet, SceRow As Long, j As Long, lr As Long, Destn As Range

Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
With Worksheets.Add
  .Name = "Forms_filled"
  .Range("A1:D1").Value = Array("unit ID", "unit Name", "type", "Yes/No")
  Set Destn = .Range("A2")
  For SceRow = 2 To lr
    If ws.Cells(SceRow, 1).Value <> "" Then 'you may not need this and the line with a similar comment below.
      For j = 3 To 18    '(columns C to R)
        Destn.Resize(, 4).Value = Array(ws.Cells(SceRow, 1).Value, ws.Cells(SceRow, 2).Value, ws.Cells(1, j).Value, ws.Cells(SceRow, j).Value)
        '                                       unit ID,                 unit Name,                  type,                 Yes/No
        Set Destn = Destn.Offset(1)
      Next j
    End If 'you may not need this and the line with a similar comment above.
  Next SceRow
  .Cells.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
End With
End Sub

[p45cal]

or try:

Sub blah()
Set ws = ActiveSheet
With Worksheets.Add
  .Name = "Forms_filled"
  .Range("A1:D1").Value = Array("unit ID", "unit Name", "type", "Yes/No")
  Set Destn = .Range("A2")
  For Each cll In ws.Range("C2:R" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
    If Not IsEmpty(cll.Value) Then
      Destn.Resize(, 4) = Array(ws.Cells(cll.Row, 1).Value, ws.Cells(cll.Row, 2).Value, ws.Cells(1, cll.Column).Value, cll.Value)
      Set Destn = Destn.Offset(1)
    End If
  Next cll
  .Cells.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
End With
End Sub

[CJW_14]

Difficult to test without a workbook, but try:

Sub test()
Dim ws As Worksheet, SceRow As Long, j As Long, lr As Long, Destn As Range

Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
With Worksheets.Add
  .Name = "Forms_filled"
  .Range("A1:D1").Value = Array("unit ID", "unit Name", "type", "Yes/No")
  Set Destn = .Range("A2")
  For SceRow = 2 To lr
    If ws.Cells(SceRow, 1).Value <> "" Then 'you may not need this and the line with a similar comment below.
      For j = 3 To 18    '(columns C to R)
        Destn.Resize(, 4).Value = Array(ws.Cells(SceRow, 1).Value, ws.Cells(SceRow, 2).Value, ws.Cells(1, j).Value, ws.Cells(SceRow, j).Value)
        '                                       unit ID,                 unit Name,                  type,                 Yes/No
        Set Destn = Destn.Offset(1)
      Next j
    End If 'you may not need this and the line with a similar comment above.
  Next SceRow
  .Cells.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
End With
End Sub

Thanks heaps mate! this one appears to be working, Ive attached an example workbook this time

Ill give the second code you just posted a go also.

[snb]

Please do not quote !
This is all you need:

Sub M_snb()
'   Sheet1.Cells(1).CurrentRegion.Columns(1).SpecialCells(4).EntireRow.Delete  'you should run this once.
   sn = Sheet1.Cells(1).CurrentRegion
   
   With CreateObject("scripting.dictionary")
    .Item(.Count) = Array(sn(1, 1), sn(1, 2), "type", "Y/N")
    For j = 2 To UBound(sn)
      For jj = 3 To UBound(sn, 2) - 4
         .Item(.Count) = Array(sn(j, 1), sn(j, 2), sn(1, jj), sn(j, jj))
      Next
    Next
    
    Sheets.Add.Cells(1).Resize(.Count, 4) = Application.Index(.items, 0, 0)
   End With
End Sub