Say I have the information:
NAME Class1 Class2 Class3
NAME2 Class2 Class3 Class4
I want to turn this into:
NAME Class1
NAME Class2
NAME Class3
NAME2 Class2
NAME2 Class3
NAME2 Class4
I'd use Paste > Transpose, except I have 550 names with up to 10 classes each. So I'd have to copy, insert 10 blank rows, paste > transpose and then trim blank rows 500 times.
Is there are better way?
With data like this in Sheet1
Running this macro:
Sub ReOrganize()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim N As Long, i As Long, j As Long, k As Long
Dim M As Long, v As String
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
k = 1
N = sh1.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
v = Cells(i, 1).Value
M = Cells(i, Columns.Count).End(xlToLeft).Column
For j = 2 To M
sh2.Cells(k, 1) = v
sh2.Cells(k, 2) = sh1.Cells(i, j)
k = k + 1
Next j
Next i
End Sub
Will produce this in Sheet2
The above answer looks like a variant of the one I ended up finding at https://superuser.com/questions/633124/how-do-i-split-one-row-into-multiple-rows-with-excel
The code itself that I used from that page is:
Sub NewLayout()
For i = 2 To Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
For j = 0 To 2
If Cells(i, 3 + j) <> vbNullString Then
intCount = intCount + 1
Cells(i, 1).Copy Destination:=Cells(intCount, 10)
Cells(i, 2).Copy Destination:=Cells(intCount, 11)
Cells(i, 3 + j).Copy Destination:=Cells(intCount, 12)
End If
Next j
Next i
End Sub
Which instead of pasting into a new sheet like the above answer, pastes into columns 10-12 of the same sheet.
Related
I currently have a data set that looks like the following:
A B C D E F G
1 x x x x x x *
2 a a a a a a
3 c c c c c c %
I need code to copy paste rows at the bottom of the data set based on if there's text in column. I would then need the text in column G to appear in column F while everything else in the row stays the same. For example, the result would be:
A B C D E F G
1 x x x x x x *
2 a a a a a a
3 c c c c c c %
4 x x x x x *
5 c c c c c %
My code currently looks like this:
Public Sub CopyRows()
Sheets("Exposure Distribution").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
' Decide if to copy based on column H
ThisValue = Cells(x, 8).Value
If Application.WorksheetFunction.IsText(ThisValue) = "True" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("Exposure Distribution").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Exposure Distribution").Select
End If
ThisValue = Cells(x, 9).Value
If Application.WorksheetFunction.IsText(ThisValue) = "True" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("Exposure Distribution").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Exposure Distribution").Select
End If
ThisValue = Cells(x, 10).Value
If Application.WorksheetFunction.IsText(ThisValue) = "True" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("Exposure Distribution").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Exposure Distribution").Select
End If
Next x
End Sub
However I don't know how to accomplish the final part of what I'm looking for, which is moving data from column G to column F based on if there's text in `column G`.
See if this helps:
Sub CopyPasteWithConditions()
Dim wb As Workbook: Set wb = ActiveWorkbook 'declare and set the workbook
Dim ws As Worksheet: Set ws = wb.Sheets("SheetNameHere") 'declare and set the worksheet
Dim lRow As Long: lRow = ws.Cells(Rows.Count, "A").End(xlUp).Row 'get the last row of current data
Dim cntTxts As Long: cntTxts = WorksheetFunction.CountA(Range("G1:G" & lRow)) 'get the number of times there is any text in G
Dim arrData As Variant: arrData = ws.Range("A1:G" & lRow + cntTxts) 'create an array of current data + number of rows required for the copied data
Dim R As Long, C As Long, X As Long
For R = LBound(arrData) To lRow 'for each row in current data
If arrData(R, 7) <> "" Then 'if there is any text in G
X = X + 1
For C = LBound(arrData, 2) To UBound(arrData, 2) - 1 'for each column in data, except last
If C = 6 Then 'if we are on the last column, get the extra text instead
arrData(lRow + X, C) = arrData(R, 7) 'add the value to the row equal to last row + value of X (pretty much the next free row)
Else 'else the other values
arrData(lRow + X, C) = arrData(R, C) 'add the value to the row equal to last row + value of X (pretty much the next free row)
End If
Next C
End If
Next R
ws.Range("A1:G" & lRow + cntTxts) = arrData 'put the data back on the sheet
End Sub
I've got a function which merges cells in table if whole range has the same value (eg. if A1:G1 is equal to A2:B2 it will merge cells like A1&A2, B1&B2 etc. More here: How to check if two ranges value is equal)
Now I would like, to change color on table created by that funcion, like first row (doesn't matter if merged or no) filled with color, second blank etc. but I have no idea whether I should color it with merging function or create another which will detect new table with merged rows as one etc. Below is my code:
Sub test()
Dim i As Long, j As Long, k As Long, row As Long
row = Cells(Rows.Count, 2).End(xlUp).row
k = 1
For i = 1 To row Step 1
If Cells(i, 1).Value = "" Then Exit For
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
k = i + 1
End If
Next i
End Sub
Try:
Option Explicit
Sub test1()
Dim LastColumn As Long, LastRow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To LastRow Step 2
.Range(Cells(i, 1), .Cells(i, LastColumn)).Interior.Color = vbGreen '<- You could change the color
Next i
End With
End Sub
Before:
After:
Edited Solution:
Option Explicit
Sub test1()
Dim rng As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .UsedRange
.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "Table1"
.ListObjects("Table1").TableStyle = "TableStyleLight3"
End With
End Sub
Result:
So, after some time I've figured it out by myself. Below is the code:
Dim i As Long, j As Long, k As Long, l As Long, c As Integer
row = Cells(Rows.Count, 2).End(xlUp).row
k = 7
c = 1
For i = 7 To row Step 1
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
Select Case c
Case 0
Range(Cells(k, 1), Cells(k, 3)).Interior.Color = xlNone
c = 1
Case 1
For l = 0 To i - k Step 1
Range(Cells(k + l, 1), Cells(k + l, 3)).Interior.Color = RGB(217, 225, 242)
Next l
c = 0
End Select
k = i + 1
End If
Next i
I have two columns in Excel with different values:
A 1
B 2
C 3
Now, I would need to pair each cell of first column with each cell of second column. So it would look like this:
A 1
A 2
A 3
B 1
B 2
B 3
C 1
C 2
C 3
Do you know how can I do this please?
Thank you heaps
With data in columns A and B try this short macro:
Sub MakeCombinations()
Dim Na As Long, Nb As Long
Dim i As Long, j As Long, K As Long
Dim rc As Long
K = 1
rc = Rows.Count
Na = Cells(rc, 1).End(xlUp).Row
Nb = Cells(rc, 2).End(xlUp).Row
For i = 1 To Na
For j = 1 To Nb
Cells(K, 3) = Cells(i, 1)
Cells(K, 4) = Cells(j, 2)
K = K + 1
Next j
Next i
End Sub
EDIT#1:
To do this without VBA, in C1 enter:
=INDEX(A:A,ROUNDUP(ROW()/COUNTA(B:B),0),1)
and copy down and in D1 enter:
=INDEX(B:B,MOD(ROW()-1,COUNTA(B:B))+1,1)
and copy down:
I modify Gary's answer with array. Not tested due to my Mac without Excel.
Sub MakeCombinations()
Dim Ary_a As Variant, Ary_b As Variant, Ary as Variant
Dim i As Long, j As Long
Ary_a = range(Cells(rows.count, 1).End(xlUp).Row, 1).value
Ary_b = range(Cells(rows.count, 2).End(xlUp).Row, 2).value
For i = lbound(ary_a) To ubound(ary_a)
For j = lbound(ary_b) To ubound(ary_b)
if not isarray(ary) then
redim ary(1, 0)
else
redim preserve ary(1, ubound(ary, 2)+1)
end if
ary(0, ubound(ary, 2)) = ary_a(i)
ary(1, ubound(ary, 2)) = ary_b(j)
Next j
Next i
cells(1, 4).resize(ubound(ary, 2)+1, ubound(ary, 1)+1).value = application.transpose(ary)
End Sub
I am trying to write a macro in VBA to transpose columns to rows in this style:
it is:
A
B
C
D
E
F
should be:
A D
B E
C F
Has someone any idea?
This should work for you:
Sub test()
Dim lastRow&, groupSize&, i&, k&
Dim rng As Range
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
groupSize = 13
k = 2 ' start the pasting in the second column
For i = 14 To lastRow
Set rng = Range(Cells(i, 1), Cells(i + groupSize - 1, 1))
rng.Cut Range(Cells(1, k), Cells(13, k))
i = i + 12
k = k + 1
Next i
End Sub
This is a modification of the correct answer of BruceWayne:
Sub test()
Dim lastRow&, groupSize&, i&, k&
Dim rng As Range
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
groupSize = 13
k = 1 ' start the pasting in the first column
j = 1
For i = 1 To lastRow
Set rng = Range(Cells(i, 1), Cells(i + groupSize - 1, 1))
rng.Cut Range(Cells(j, k), Cells(j + 12, k))
k = k + 1
i = i + 12
If k = 14 Then
k = 1
j = j + 13
End If
Next i
End Sub
The only difference is that now the data are written not in a single row but in a group of rows. All credits to BruceWayne.
I'm a Macro novice - just figured out how to add the developer tab, so sorry if my question is dumb. I have a list of items in Column A and quantity in Column B. I want to copy Columns A and B to Columns D and E, but only if the value in Column B > 0 - and I want them to stack, no blank spaces for the quantity = 0 ones. I found some code online:
Sub copyAboveZero()
Dim sourceRng As Range
Dim cell As Range
Dim i As Long
Set sourceRng = ActiveSheet.Range("B6:B24")
i = 6
For Each cell In sourceRng
If cell.Value > 0 Then
cell.Resize(1, 2).Copy Destination:=Range("D" & i)
i = i + 1
End If
Next cell
End Sub
The problem is that in this example, the quantity was in the first cell. This one is copying Columns B and C, and I want it to copy A and B. What do I need to change? Also, can you paste special values only? I don't want the formatting to come with it.
How about:
Sub KopyKat()
Dim N As Long, i As Long
Dim j As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 1 To N
If Cells(i, "B").Value > 0 Then
Range(Cells(i, "A"), Cells(i, "B")).Copy Cells(j, "D")
j = j + 1
End If
Next i
End Sub
EDIT#1:
This addresses your comments:
Sub KopyKat()
Dim N As Long, i As Long
Dim J As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
J = 6
For i = 6 To N
If Cells(i, "B").Value > 0 And Cells(i, "B") <> "" Then
Range(Cells(i, "A"), Cells(i, "B")).Copy
Cells(J, "D").PasteSpecial (xlValues)
J = J + 1
End If
Next i
End Sub