I'm trying to delete all rows with cell values non equivalent to one of the values from array Ar(). When I put logical operator NOT loop goes infinite for some reason (excel freezes). In opposite it works flawlessly, in case if I would want to delete rows containing values from array.
The problem is on line:
If Not .Cells(i, 10).Value = Ar(j) Then
My code:
Sub Tims()
Dim LastRow As Long, LR As Long
Dim i As Long, j As Long
Dim t As Integer
Dim Ar() As String
Worksheets("Start").Activate
t = Count("a", Range("A3:A14"))
LR = Range("I3:I10").End(xlDown).Row
Worksheets("Master").Activate
Sheets("Master").Range("A100:A" & 100 + LR - 3).Value = Sheets("start").Range("I3:I" & LR).Value
With Worksheets("Master")
For j = 1 To LR - 2
ReDim Preserve Ar(j)
Ar(j) = Cells(99 + j, 1)
Next j
End With
With Worksheets("Master")
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
Worksheets("Master").Activate
For j = 1 To LR - 2
For i = 1 To LastRow
With Worksheets("Master")
If Not .Cells(i, 10).Value = Ar(j) Then
.Cells(i, 10).EntireRow.Delete
i = i - 1
End If
End With
Next i
Next j
End Sub
The line causing the infinite loop is this one:
i = i - 1
Get rid of it, and replace this
For i = 1 To LastRow
with this
For i = LastRow To 1 Step -1
I see why you tried i = i - 1 in order to avoid skipping a row each time a row is deleted. But that doesn't work: if a row gets deleted, then it is replaced by an empty row at the bottom of your table, and eventually you reach it. This empty row obviously does not contain any of the values in your array Ar(j), so it gets deleted and replaced by another empty row, which then gets deleted and replaced by another empty row, ad infinitum.
You could have figured this out yourself had you stepped through your code in debug mode.
Instead, just iterate from the bottom up using Step -1.
Related
I have a table with information in column A and an appropriate value in column B. I want to write a macro that inserts a new row for each "Person" in dependence of the value in column B and copies the original information into that row, which for example means that in the end there are 5 rows with "Person A", 2 rows for "Person B" etc.
original table:
result:
My first approach looks like that. It doesn't work.
Dim i, j, k As Integer
For i = Range("A" & Range("A:A").Rows.Count).End(xlUp).Row To 1 Step -1
For j = 1 To Range("B" & i)
Rows(i).Select
Selection.Insert Shift:=xlDown
k = k + j
Range(Cells(k, 1), Cells(k, 2)).Copy Destination:=Range("A" & i)
Next j
Next i
This would work for you, changing the number of inserts based on value in column B:
Option Explicit
Sub test()
With Sheets(1)
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = lastRow To 1 Step -1
If IsNumeric(.Cells(i, 2).Value) = True Then
Dim numberOfInserts As Long
numberOfInserts = .Cells(i, 2).Value - 1
If numberOfInserts > 0 Then
Dim insertCount As Long
For insertCount = 1 To numberOfInserts
.Rows(i).Copy
.Rows(i).Insert
Next insertCount
End If
End If
Next i
End With
End Sub
First we check that you're dealing with numbers. Second you have a single line already, so number -1, then that this number is >0. Lastly, you insert via a loop which does the counting for you.
Test data:
Output after running:
Your index calculation is messed up. Use the debugger, step thru the code (F8) and notice what happens:
a) Your Select/Insert-construct creates a new row above the row you want to copy, not below.
b) Your calculation of index k fails: You are not initializing k, so it starts with value 0. Than you add j (1..3) to k, resulting in values 1, 3, 6, and copy data from that line.
I would suggest you take a different approach: Copy the original data into an array and then loop over that array. This avoids multiple Select, Copy and Insert statements (that are slow) and allow to copy the data from top to bottom.
Sub copy()
Dim rowCount As Long
Dim data As Variant
With ActiveSheet ' Replace with the sheet you want to work with
' Copy the current table into array
rowCount = .Cells(.Rows.Count, 1).End(xlUp).row
data = .Range(.Cells(1, 1), .Cells(rowCount, 2))
Dim oldRow As Long, newRow As Long
newRow = 1
' Loop over old data
For oldRow = 1 To rowCount
Dim repeatCount As Long
repeatCount = Val(data(oldRow, 2)) ' We want to have so many occurrences of the row
if repeatCount <= 0 Then repeatCount=1
Dim col As Long
' Create "repeatCount" rows of data (copy column by column)
For col = 1 To 2
.Cells(newRow, col).Resize(repeatCount, 1) = data(oldRow, col)
Next col
newRow = newRow + repeatCount
Next
End With
End Sub
I am having an issue getting array values to compare to values stored in cells on the spreadsheet.
I have tried having the cell value compare directly to the array value, but the check fails every time.
To attempt to correct this issue I have tried assigning the cell value on each iteration to a variable dimmed as varient (Just as the array is dimmed a varient)
Values are added to the array successfully and the varient type is used as some invoices are numbers only while others include letters.
When I walk through my code the variable is not being assigned/accepting a value. Every time the comparison statement is reached the variable shows that it is empty.
Dim Paidlrow As Long
Dim lrow As Long
Dim wb As Workbook
Dim Consolid As Worksheet
Dim PaidInv As Worksheet
Dim Summary As Worksheet
Dim Invoices() As Variant
Dim InvCheck As Variant
Dim txt As String
Dim Formula As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim Cleared As Long
Dim LInv As Long
Dim NewBlank As Long
Dim MaxSheets As Integer
Set wb = Workbooks("Wire Payments projections for Euro's")
Set Consolid = wb.Sheets("Consolidation")
Set Summary = wb.Sheets("Pay Summary")
Set PaidInv = wb.Sheets("Paid Invoices")
'define define and define
MaxSheets = wb.Sheets.Count
lrow = Consolid.Cells(Rows.Count, 1).End(xlUp).Row + 1
Cleared = 1
ReDim Preserve Invoices(1 To Cleared)
i = 2
With wb
'begin inv extraction loop
For i = 2 To lrow
ReDim Preserve Invoices(1 To Cleared)
'if inv is marked for payment, add to array and move details to paid inv tab
With PaidInv
Paidlrow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
End With
With Consolid
If .Cells(i, 10) = "X" Or .Cells(i, 10) = "x" Then
Invoices(Cleared) = .Cells(i, 1)
Consolid.Rows(i).Copy Destination:=PaidInv.Cells(Paidlrow, 1)
Consolid.Rows(i).Clear
Cleared = Cleared + 1
End If
End With
Next i
End With
'loop through each sheet to remove paid invoices identifie in previous loop
For k = 1 To MaxSheets
If wb.Sheets(k).Name <> Summary.Name And wb.Sheets(k).Name <> PaidInv.Name And wb.Sheets(k).Name <> Consolid.Name Then
With wb.Sheets(k)
LInv = Cells(Rows.Count, 2).End(xlUp).Row + 1
For j = LBound(Invoices) To UBound(Invoices)
For l = 7 To LInv
InvCheck = .Cells(l, 2).Value
If Invoices(j) = InvCheck And InvCheck <> "" Then
'.Rows(l).Delete
NewBlank = Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("A7:K7").Copy
.Range(.Cells(NewBlank, 1), .Cells(NewBlank, 11)).PasteSpecial Paste:=xlPasteFormats
'.Cells(NewBlank, 1) = Right(.Cells(1, 9), 6)
'Formula = "=$B$3*I"
'Formula = Formula & NewBlank
'.Cells(NewBlank, 10).Formula = Formula
End If
Next l
Next j
End With
End If
Next k
I have commented out code for the ease of testing. With the way it is now it should format some additional cells to match the formatting above it.
UPDATE
For kicks and giggles, I changed the Array and associated variable check to String type rather than variant. For some reason, this fixed the issue I was having. I am so confused...
There seems to be a dot missing:
With wb.Sheets(k)
LInv = Cells(Rows.Count, 2).End(xlUp).Row + 1
should be:
With wb.Sheets(k)
LInv = .Cells(Rows.Count, 2).End(xlUp).Row + 1
to ensure that LInv is read from sheet number k.
As it is, the code is equivalent to:
With wb.Sheets(k)
LInv = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row + 1
and, if the active sheet doesn't have any values in the cells you are looking at, the comparison will fail.
There's a similar issue with this line later on in the code:
NewBlank = Cells(Rows.Count, 1).End(xlUp).Row + 1
should be:
NewBlank = .Cells(Rows.Count, 1).End(xlUp).Row + 1
So I have a double loop that for some reason always skips to my outer loop for some reason. The loop goes from:
For j = lastColumn To 6 Step (-1)
to:
Next i
every single time. However, in my data set there's a mixed variety of data which should be captured in my if statement and count the data.
Any ideas? Maybe I formatted the macro wrongly.
Sub CheckDates()
Dim count As Integer
Dim i As Integer
Dim j As Integer
Sheets(1).Select
lastrow = ActiveSheet.Cells(Rows.count, "B").End(xlUp).Row
'have to keep data in a table for this to actually work as it ctrls+left to the table, which will end where the very last text of any row is
lastColumn = ActiveSheet.Cells(1, Columns.count).End(xlToLeft).Column
count = 0
i = 3
j = lastColumn
For i = 3 To lastrow
For j = lastColumn To 6 Step (-1)
If Sheet1.Cells(i, j) < Sheet2.Cells(1, 1) And Sheet1.Cells(i, j - 1) = "Reçu" Then
count = count + 1
GoTo NextIteration
End If
Next j
NextIteration:
Next i
Sheet2.Cells(1, 7) = count
Sheets(2).Select
'Runs the DeleteSAC Macro
Call DeleteSAC
End Sub
I don't quite follow what you're doing, but try this instead. Notice the Exit For. This should produce the result you're looking for, without the For-Next counter variables getting confused.
For i = 3 To lastrow
For j = lastColumn To 6 Step (-1)
If Sheet1.Cells(i, j) < Sheet2.Cells(1, 1) And Sheet1.Cells(i, j - 1) = "Reçu" Then
count = count + 1
Exit For
End If
Next j
Next i
Simplification
Use Long for rows, and Integer for columns.
When you write With Sheet1, everywhere where you should write Sheet1, e.g. Sheet1.Range(whatever)... you can write just .Range(whatever) instead, until you close with End With.
The Exit For exits only the For Loop where it is in. So it does exactly what you are doing with your Goto line, but you are using a line more.
When you use Sheet1 or Sheet2 etc. you are actually using code names so you can change the names in the tab and the code will still run.
Counting backwards is usually used when you delete row by row so there is no need to do so since you are only counting.
Option Explicit
Sub CheckDates()
Dim dataCount As Long
Dim i As Long
Dim j As Integer
Dim lastrow As Long
With Sheet1
lastrow = .Cells(.Rows.count, "B").End(xlUp).Row
'have to keep data in a table for this to actually work as it ctrls+left
'to the table, which will end where the very last text of any row is
lastColumn = .Cells(1, .Columns.count).End(xlToLeft).Column
For i = 3 To lastrow
For j = 6 To lastColumn
If .Cells(i, j) < Sheet2.Cells(1, 1) And .Cells(i, j - 1) = "Reçu" Then
dataCount = dataCount + 1
Exit For
End If
Next
Next
End With
With Sheet2
.Cells(1, 7) = dataCount
.Select
End With
'Runs the DeleteSAC Macro
DeleteSAC
End Sub
I am trying to erase duplicate rows starting from bottom, but it isnt working. It keeps two copies but deletes other duplicate items.
With wb_DST.Sheets(sWs_DST)
lncheckduplicatescolumn = .Cells(.Rows.Count, "A").End(xlUp).row
wb_DST.Sheets(sWs_DST).Range(("A13:A" & lncheckduplicatescolumn - 2 & ":" & "AW13:AW" & lncheckduplicatescolumn - 2)).Sort key1:=wb_DST.Sheets(sWs_DST).Range("A13:A" & lncheckduplicatescolumn - 2), order1:=xlDescending, Header:=xlNo
Dim row As Range
Dim rng As Range
Dim cell As Range
Dim i As Integer
Set rng = wb_DST.Sheets(sWs_DST).Range("A13:A" & lncheckduplicatescolumn - 2)
For Each cell In rng
If cell.Value = cell.Offset(-1, 0).Value Then
.cell.Offset(-1, 0).EntireRow.Delete
End If
Next
End with
If Excel shows
Column A Column B
A 1
A 2
A 3
I want the code to retain the last row, and delete the ones above it.
The result should be
Column A Column B
A 3
Thanks,
Work from the bottom up and loop until all 'higher' (i.e. in a row less than current) are removed.
dim dup as variant, r as long, lncheckduplicatescolumn as long
With wb_DST.Sheets(sWs_DST)
lncheckduplicatescolumn = .Cells(.Rows.Count, "A").End(xlUp).row
for r = lncheckduplicatescolumn to 2 step -1
dup = application.match(.cells(r, "A").value, .columns(1), 0)
if dup < r then .rows(dup).delete
next r
end with
This will take a few more cycles than is absolutely necessary but the operation is efficient enough that it should not make a significant difference.
Dim x as integer
Dim y as string
Dim J as integer
Dim I as integer
x = activesheet.range("A" & Activesheet.range("A1").endxl.down).count 'This will count the total number of rows.
for i = x to 2 'this should count backwards from bottom to top, since you have headers, stop at row 2
y = Activesheet.range("A" & i).value 'places value in a variable
For j = x - i - 1 to 1 'this is another loop, but it should start above the whatever the cell that Y got its value
if activesheet.range("a" & j).value = y then 'comparison
'do what you need to delete the row
end if
Next
Next
I think this will go start at the bottom, put that first value in a variable, and then will go through the rest of the list check the values to see if is compatible. The second for loop might need to be adjusted.
not a pretty answer - but from what it looks like, you should be ending up with the last and first occurrence of the duplicate:
Column A Column B
A 1
A 3
To patch your answer (there are more elegant ways), you could find the last row again after the loop is finished and check for one last duplicate:
For Each cell In rng
If cell.Value = cell.Offset(-1, 0).Value Then
.cell.Offset(-1, 0).EntireRow.Delete
End If
Next
redefine your last row
lncheckduplicatescolumn = .Cells(.Rows.Count, "A").End(xlUp).row
and check for one more duplicate
If Range("A" & lncheckduplicatescolumn).Value = Range("A" & lncheckduplicatescolumn).Offset(-1, 0).Value Then
.cell.Offset(-1, 0).EntireRow.Delete
End If
Text “endofdata” in col B identifies the boundaries of multiple ranges on a single sheet. I’m trying to step through each range and remove duplicate values in columns E and F within each range. I also call a routine that deletes blank rows that are generated when duplicates are removed. The bottom row with “endofdata” is always removed when .removeduplicates is executed.
I’ve tried the Do loop but it’s failing. (It works for the first range but fails for the next range) Please suggest how to make this work. What kind of loop should I use? How should I search for “endofdata” string? Thank you very much in advance.
Sub RemoveDupsinRange()
Dim LastRow As Long, i As Long, startRow, EndRow
Call setSheets
LastRow = wsQC.Cells(wsQC.Rows.Count, "A").End(xlUp).Row
Debug.Print LastRow
For i = LastRow To 1 Step -1
Do
If wsQC.Cells(i, 2).Value = "endofdata" Then
startRow = i
End If
i = i - 1
Loop Until wsQC.Cells(i, 2).Value = "endofdata"
EndRow = i
i = i - 1
Range(startRow & ":" & EndRow).Select
Selection.removeduplicates Columns:=Array(5, 6), _
Header:=xlNo
Call DeleteBlanks
Next i
End Sub
I just tested this loop and it worked.
Sub RemoveDupsinRange()
Dim LastRow As Long, i As Long, rStart As Range, rEnd As Range
Call setSheets
LastRow = wsQC.Cells(wsQC.Rows.Count, "A").End(xlUp).Row
Debug.Print LastRow
Set rEnd = wsQC.Cells(LastRow, 2)
For i = LastRow To 2 Step -1
Do
i = i - 1
If wsQC.Cells(i, 2).Value = "endofdata" Then
Set rStart = wsQC.Cells(i, 2)
End If
Loop Until wsQC.Cells(i, 2).Value = "endofdata"
wsQC.Range(rStart.Offset(, -1), rEnd.Offset(, 4)).RemoveDuplicates Columns:=Array(5, 6), Header:=xlNo
Set rEnd = rStart
Call DeleteBlanks
Next i
End Sub