View Full Version : Converting columns to rows
CJW_14
08-27-2018, 09:50 PM
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
08-28-2018, 02:54 AM
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
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
08-28-2018, 01:59 PM
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
08-28-2018, 02:57 PM
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
08-28-2018, 03:10 PM
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.
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.