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 = ""
Related
I have a data set that consists of columns A-D. Values in A and D are the same respectively, as are B and C. It is listed for the purposes of A correlating to B, and C to D. What I would like to do is to be able to create a new two column list using the combinations of A&B and C&D. But I need them to go in the order they are originally listed i.e. new sheet, Row 1 A&B, Row 2 C&D, Row 3 A&B etc.
At first I tried simple filters and sorting, but due to the range of the data set at times, it makes the values that need to be close too each other too far. I tried a few failed splices and cuts. I had hoped there would just be a built in excel function.
Option Explicit
Sub combineList()
Dim i As Long
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If Cells(i, 1) = "" Then
'do nothing
Else
If Cells(i, 9) = "" Then
Cells(i, 9) = Cells(i, 1)
Cells(i, 10) = Cells(i, 2)
Cells(i + 1, 9) = Cells(i, 4)
Cells(i + 1, 10) = Cells(i, 5)
Else
i = i + 1
Cells(i, 9) = Cells(i, 1)
Cells(i, 10) = Cells(i, 2)
Cells(i + 1, 9) = Cells(i, 4)
Cells(i + 1, 10) = Cells(i, 5)
'i = i - 1
End If
End If
Next i
End With
End Sub
First attempt, trying to get it to skip over rows for C&D.
Sub newMethod()
Dim i As Long
Dim j As Long
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("a" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow Step -1
If Cells(i, 1) = "" Then
'do nothing
Else
Cells(i, 9) = Cells(i, 1)
Cells(i, 10) = Cells(i, 2)
'i = i + 1
End If
Next i
For j = 2 To lRow Step 2
If Cells(j, 1) = "" Then
'do nothing
Else
Cells(j + 1, 9) = Cells(j, 4)
Cells(j + 1, 10) = Cells(j, 5)
'j = j + 1
End If
Next j
End With
End Sub
As stated above, to be able to reorganize the list by "shuffling" it together. Basically each row split into two. My attempts have ended with loops that just constantly overwrite themselves.
You can obtain your desired results using formulas.
It is a matter of deriving the mathematics of obtaining the correct row/col numbers in sequence.
F2: =INDEX($A:$D,FLOOR(ROWS($1:2)/2,1)+1,MOD(ROWS($1:2),2)*2+1)
G2: =INDEX($A:$D,FLOOR(ROWS($1:2)/2,1)+1,MOD(ROWS($1:2),2)*2+2)
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 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:
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