I am working in Excel with the following data structure:
A 1
2
B 2
C 2
3
4
D 3
4
And would like to change it to:
A 1,2
B 2
C 2,3,4
D 3,4
Thanks for your time!
Try this short macro:
Sub reorg()
Dim i As Long, N As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = N To 2 Step -1
If Cells(i, 1).Value = "" Then
Cells(i - 1, 2).Value = Cells(i - 1, 2).Value & "," & Cells(i, 2).Value
Cells(i, i).EntireRow.Delete
End If
Next i
End Sub
Before:
and after:
Related
I have a column of integers with consecutive duplicates.
I'd like to insert a row after each consecutive match.
My values are:
2
2
5
5
10
10
20
20
The code's output is:
2
2
5
5
10
10
20
20
It is working, up until it is differentiating between 2 and 5.
For k = myRange.Rows.Count To 2 Step -1
If InStrRev(myRange.Cells(k, 1).Value2, vbTextCompare) <> InStrRev(myRange.Cells(k - 1, 1).Value2, vbTextCompare) Then
Range(myRange.Cells(k, 1).EntireRow, myRange.Cells(k, 1).EntireRow).Insert
End If
Next k
Where 'myRange' is the range of values to separate.
I tried using myRange.Cells(k,1).Text instead of Value2, and also tried doing a vbBinaryCompare instead of a text compare.
Here is a simple example of what you are trying to do.
For k = myRange.Rows.Count To 3 Step -1 'If you have a header and loop to row 2 it will insert a row above row 2
If Cells(k, 1) <> Cells(k - 1, 1) Then
Cells(k, 1).EntireRow.Insert
End If
Next k
dim r as range
Set r = Range("a1")
irow = r.Row
icol = r.Column
Do
If Cells(irow + 1, icol) <> Cells(irow, icol) Then
Cells(irow + 1, icol).EntireRow.Insert shift:=xlDown
irow = irow + 2
Else
irow = irow + 1
End If
Loop While Not Cells(irow, icol).Text = ""
I have two columns, Column A has a set of a few standard values and column B has all unique values. I'm only just experimenting with more complex ways of compiling data than the beginner level so I'm a bit at a loss.
I need to either have a lookup or create a macro that will list only the values in A (once each) but also display which values in B correspond to those in A
for example
A | B
va1|abc
va1|bcd
Va2|xyz
va3|zab
will show (in a single cell) the following
va1: abc, bcd
va2: xyz
va3: zab
Please help!
Option Explicit
Sub Test()
Dim i As Long, j As Long, k As Long
k = 1
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Application.CountIf(Range("C:C"), Cells(i, 1).Value) = 0 Then
Cells(k, 3).Value = Cells(i, 1).Value
For j = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(j, 1).Value = Cells(k, 3).Value And _
InStr(Cells(k, 4).Value, Cells(j, 2).Value) = 0 Then
If Cells(k, 4).Value = "" Then
Cells(k, 4).Value = Cells(j, 2).Value
Else
Cells(k, 4).Value = Cells(k, 4).Value & ", " & Cells(j, 2).Value
End If
End If
Next j
k = k + 1
End If
Next i
For i = 1 To Cells(Rows.Count, 3).End(xlUp).Row
Cells(i, 3).Value = Cells(i, 3).Value & ": " & Cells(i, 4).Value
Cells(i, 4).ClearContents
Next i
End Sub
Edited for single cell
In case your requirement is to "have the grouped data", and not exactly "have one single string per A", you can do this with a "pivot table" putting A and B in the row labels, like in the following picture:
can someone help me with that? In column C, individual cells are initially empty, and the code works in the section. In the sections where there are several empty cells in column C, the code does not work. What exactly do I have to change regarding "lastrow2" or at an other position of the code to achieve the desired goal?
lastrow2 = Cells(Cells.Rows.Count, "C").End(xlUp).Row
For j = lastrow2 To 1 Step -1
If (Cells(j, 4) = 0 And Cells(j, 5) = 0 And Cells(j, 6) = 0 And Cells(j, 7) = 0 And Cells(j, 8) = 0 And Cells(j, 9) = 0) Then
Rows(j).Delete
End If
Next j
Would be very grateful for your support. :)
Best regards,
Bamane
Testing column C may be too shallow. This:
Sub trewq()
ActiveSheet.UsedRange
Set r = ActiveSheet.UsedRange
lastrow2 = r.Rows.Count + r.Row - 1
For j = lastrow2 To 1 Step -1
If (Cells(j, 4) = 0 And Cells(j, 5) = 0 And Cells(j, 6) = 0 And Cells(j, 7) = 0 And Cells(j, 8) = 0 And Cells(j, 9) = 0) Then
Rows(j).Delete
End If
Next j
End Sub
may be better..................we are checking columns D through I
Instead of checking that each cell = 0, why not use a couple of formulas?
Sub DeleteRowsWithZero()
Dim lastrow As Long
lastrow = Cells(Cells.Rows.Count, "C").End(xlUp).Row
Dim j As Long
For j = lastrow To 1 Step -1
If WorksheetFunction.Sum(Range("D" & j & ":I" & j)) = 0 And _
WorksheetFunction.CountIf(Range("D" & j & ":I" & j), "*") = 0 Then
Rows(j).Delete
End If
Next
End Sub
WorksheetFunction.Sum() checks that all the cells in your test range have a value of 0.
But if some of those cells have a text value rather than a numeric value, you'll still get 0, so we then use WorksheetFunction.CountIf() to test that none of those cells contain text (by checking against the wildcard "*").
If both checks = 0, then we can delete the row.
I'm trying to copy a cell and the adjacent cell in a row and insert it as a new row with all the data to the right of this cell also copied over. My data looks like this after mining.
and im trying to get my data to look like this:
the image above is just one record but essentially its moving all the people and their corresponding position in the original row to a new row. In each row there are about 5 employees and their positions.
thanks
EDIT Attempted code for just 2 cols. 1 position. the idea was to create the empty rows and just copy the rest of the data with auto fill, then work from there
Sub TransposeInsertRows()
Dim rng As Range
Dim i As Long, j As Long, k As Long
Dim x As Long, y As Long
Set rng = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Enter the name col and pos col", Type:=8)
Application.ScreenUpdating = False
x = rng(1, 1).Column + 2
y = rng(1, rng.Columns.Count).Column
For i = rng(rng.Rows.Count, 1).Row To rng(1, 1).Row Step -1
If Cells(i, x) <> "" And Cells(i, x + 1) <> "" Then
k = Cells(i, x - 2).End(xlToRight).Column
If k > y Then k = y
For j = k To x + 1 Step -1
Cells(i + 1, 1).EntireRow.Insert
With Cells(i + 1, x - 2)
.Value = .Offset(-1, 0)
.Offset(0, 1) = .Offset(-1, 1)
.Offset(0, 2) = Cells(i, j)
End With
Cells(i, j).ClearContents
Next j
End If
Next i
Application.ScreenUpdating = True
End Sub
If there are always 5 people in each row then this should do it:
Sub foo()
LastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow 'loop through rows
For x = 1 To 10 Step 2 'loop through columns
LastRow2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row + 1 'find the next free row on Sheet2
Sheet2.Cells(LastRow2, 1).Value = Sheet1.Cells(i, x).Value 'add Person Name to Sheet2
Sheet2.Cells(LastRow2, 2).Value = Sheet1.Cells(i, x + 1).Value 'add position to Sheet2
Sheet1.Range("K" & i & ":U" & i).Copy Destination:=Sheet2.Cells(LastRow2, 3) 'copy range from K to U to Sheet2
Next x
Next i
End Sub
I know how to insert rows for sequential missing values, but how can I do this for unique values that I store in a range? For example:
Range of all needed values New list with missing values
2 2
3 5
5 7
6 15
7
10
15
The code below adds rows in a sequence (i.e. if list is 2 3 5, it adds 4) so it's not what I need but I don't know how to make it loop through a range and take values only from it
Sub RowsInSequence()
Dim i As Long, j As Long
i = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For j = i To 1 Step -1
If Cells(j + 1, 1) <> "" Then
If Cells(j + 1, 1).Value - Cells(j, 1).Value > 1 Then
x = Cells(j + 1, 1).Value - Cells(j, 1).Value
Rows(j + 1 & ":" & x + j - 1).Insert
End If
End If
Next j
With Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
.Formula = "=Row()"
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub