Ok I have tried these and grasped some view on variants and I have written these code
Sub main()
Dim Vary As Variant
Vary = Sheet1.Range("A1:D11").Value
For i = 1 To UBound(Vary)
For j = i + 1 To UBound(Vary)
If Vary(i, 1) = Vary(j, 1) Then
'I should delete the vary(j,1) element from vary
'in excel sheet we use selection.entirerow.delete
End If
Next j
Next i
End Sub
This is the sample I tried
A B C D
1 somevalues in BCD columns
2
3
1
Now Delete the 4th row don think I'm working for unique records I'm just learning stuff to do and while I was learning variant I am stuck at this point deleting a complete row stored in variant
I have stored (A1:D11).value in variant
Now how can I delete the A6 element or row in variant so that I can avoid it while I copy the variant to some other sheet?
Can I also delete the C AND B columns in variant so that when i do transpose it wont copy the C and B columns?
I don't know what exactly a variant is - I was thinking to take a set of range and do operations like what we do for an excel sheet then take that variant and transpose it back to sheet.
Is that the right way of thinking or did I misunderstand the use of variants?
`variant(k,1)=text(x)` some array shows mismatch ? whats wrong?
If you are planning on using a varray to look at cells in each row to decide if you should delete the row or not, you should loop through your varray backwards, the same way you would if you did a for loop through the cell range. Since you are starting on row 1, the variable i will always equal the row number the element was located on, so you can use that to delete the proper row.
Here's a sample (more simple than what you are trying to do, though) that will delete each row in which the cells in columns A and B are the same.
Sub test()
Dim varray As Variant
varray = Range("A1:B11").Value
For i = UBound(varray, 1) To 1 Step -1
If varray(i, 1) = varray(i, 2) Then
Cells(i, 1).EntireRow.Delete
End If
Next
End Sub
Notes of interest:
UBound(varray, 1) gives the count of the rows
UBound(varray, 2) gives the count of the columns
One workaround without a second array is to introduce a deliberate error into an element you want to replace, then use SpecialCells to delete the cell after dumping the variant array back over the range. This sample introduces an error into the array position corresponding to A6 (outside the loop as its an example), then when the range is dumped to E1, the SpecialCell error removal shifts F6:H6 into E6:G6. ie
pls save before testing - this code will overwrite E6:H11 in the first worksheet
Sub main()
Dim Vary As Variant
Dim rng1 As Range
Set rng1 = Sheets(1).Range("A1:D11")
Set rng2 = rng1.Offset(0, 4)
Vary = rng1.Value2
For i = 1 To UBound(Vary)
For j = i + 1 To UBound(Vary)
'your test here
Next j
Next i
Vary(6, 1) = "=(1 / 0)"
With rng2
.Value2 = Vary
On Error Resume Next
.SpecialCells(xlFormulas, xlErrors).Delete xlToLeft
End With
End Sub
Related
I have a worksheet that uses randomly generated numbers in calculations to produce results in two adjacent cells (let's say A1 and A2). I am trying to perform 100 iterations where I'm simply "Calculating Formulas" on the worksheet and then trying to store the results of each iteration next to A1 and A2 (so iteration 1 would be in B1 and B2 and iteration 100 would be in CW1 and CW2). Thanks in advance for your help. Using Excel 2010 if that matters.
Dim Iteration As Integer, i As Integer
Dim val As Variant
Iteration = 100
For i = 1 To Iteration
Calculate
Range("A1:A2").Select
Selection.Copy
Range("B" & Rows.Count).End(x1Up).Offset(0, 1).PasteSpecial
Paste:=xlPasteValues
Next i
End Sub
I think your major problem was with the location you were selecting for the destination address - you were finding the last unused cell in column B, then shifting over one column (i.e. to column C) and pasting the first set of results. Then you were using that same location for the second set of results, etc.
Sub Test()
Dim Iteration As Integer, i As Integer
Dim val As Variant
Iteration = 100
'Use a "With" block so that it can be easily changed in the future
'to refer to a specific sheet if needed
With ActiveSheet
For i = 1 To Iteration
Calculate
'Determine the last used column on row 1,
' offset 1 column to the right,
' resize to refer to 2 rows,
' set values to the values in A1:A2
.Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1).Resize(2, 1).Value = .Range("A1:A2").Value
Next i
End With
End Sub
As pointed out by Steve Lovell, you also had a typo in your original code. It is a good habit to include Option Explicit as the first line in every code module. That will force you to declare all the variables that you use, and the compiler would have highlighted x1Up and given a "Variable not defined" error.
I'm a newbie to VBA/coding in general and my usual tactic of sticking bits of pre-written code isn't working for my problem.
I'm looking to create a macro that will do 3 things:
Allow me to find a starting point for the data in a column.
Start counting the number of rows once the cell value has
changed to a constant.
Once the value moves back to the starting point for the count to stop and record the number of cells counted in separate column with positioning of the count in that column at the start point of the count.
Repeat until the end of the data.
For this case the start point will be when the cell has a value of >0.
It will increase to a constant number (300).
Once at 300 the macro will have to count the number of rows that contain the numerical value 300 until the value goes back to 0.
Report count in a separate table on the worksheet with the entry being input at the same relative position in the new table as when the count started from the data.
And finally the loop.
I need to also do a similar count but in the horizontal direction (i.e. counting columns on a row). If anyone can create a code for the vertical/row count problem above I'd really appreciate it if you could annotate it so I can attempt to understand/learn which bits of code carry out each action and thus change it up for horizontal/column count.
I've attached a screenshot of the spreadsheet however as a new user it must be as a link. The blue highlighted table is the data used for the vertical /row count problem I am talking about. The blank table underneath the highlighted table has manually inputted correct answers for the first column of data for what I would like the macro to do in case I haven't accurately described my request.
I have also attached the horizontal table with correct manually inputted answers for row 1 in the separate table for the column count along the row.
Lastly, here is the code that I have written to tackle the problem, however it is very basic and won't run.
Sub Count0()
For Each c In Worksheets("Sheet1").Range("D30:D39")
If c.Value = 0 Then
End If
If c.Value > 0 Then
v = Range(c.Value)
For i = 3 To Rows.Count
If Cells(i, 1).Value <> v Then
MsgBox CStr(i - 2)
End If
Next i
Next c
End Sub
This worked in the limited case I tested (two columns and several rows in different patterns. It's pretty basic--there are more elegant ways to do it.
Sub Count0()
'To hold the current cell
Dim current As Range
'To hold the total number of rows and columns having data
Dim rows As Long
Dim cols As Long
'To iterate across rows and columns
Dim r As Long
Dim c As Long
'Flag/counter variables
Dim found As Long 'Saves row on which first "constant" was found
Dim count As Long 'Saves count of "contants"
'Use SpecialCells method to obtain the maximum number of rows and columns
' that have data.
cols = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Column
rows = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row
'Increment through all columns that have data. This is a bit inefficient
' because it really isn't necessary to go through all the empty cells,
' but it works.
For c = 1 To cols
'Initialize flag/counter
found = 0
count = 0
'Increment through all rows for the current column.
For r = 1 To rows
'Examine the current cell
Set current = Worksheets("Sheet1").Cells(r, c)
'For positive values, save the first row that has the value
' and count the number of values.
If current.Value > 0 Then
If found = 0 Then found = r
count = count + 1
End If
'When the next non-positive value is reached--OR the end of the
' row is reached--and there was a constant found, write the count
' to the next worksheet in the cell corresponding to the row and
' column having the first instance of the constant.
If (current.Value <= 0 Or r = rows) And found > 0 Then
Worksheets("Sheet2").Cells(found, c).Value = count
'Reset the flag/counter
found = 0
count = 0
End If
Next r
Next c
End Sub
I was struggling with what you had written, and ended up doing this in the end. I left you variables for changing the sheets to read from and print to (assuming you can print the results to another sheet- if not it should be easy enough to change).
This should also work for all cells in your range, assuming that there are values in all boxes.
Problems I noted with your original code were:
The first if did nothing
I'm pretty sure you shouldn't use numbers in sub/function names
Dimensioning no variables is a bad idea
Anyway, give me a comment if you need any help (and well done for writing a good first question).
Sub CountZero()
Dim SourceSheet As Worksheet, SummarySheet As Worksheet
Dim CurrentCell As Range
Dim FirstRow As Long, LastRow As Long
Dim FirstColumn As Long, LastColumn As Long
Dim TotalValues As Long
Set SourceSheet = Worksheets("Sheet1")
Set SummarySheet = Worksheets("Sheet2")
FirstRow = 1
LastRow = SourceSheet.Range("A" & rows.count).End(xlUp).row
FirstColumn = 1
LastColumn = SourceSheet.Cells(1, Columns.count).End(xlToLeft).column
For col = FirstColumn To LastColumn
For Rw = FirstRow To LastRow
Set CurrentCell = SourceSheet.Cells(Rw, col)
If CurrentCell <> 0 Then
TotalValues = ProcessSection(CurrentCell)
SummarySheet.Cells(Rw, col).value = TotalValues
Rw = Rw + TotalValues
End If
Next Rw
Next col
End Sub
Function ProcessSection(FirstCellWithValue As Range) As Long
Dim Counter As Long: Counter = 0
Do Until FirstCellWithValue.Offset(Counter, 0).value <> FirstCellWithValue.value
Counter = Counter + 1
Loop
ProcessSection = Counter
End Function
As a small disclaimer, I haven't tested this, let me know if there are problems.
I'm trying to delete entire rows in Excel 2013 but only if all cells in columns K, L and M are 0/$0.00.
Example of my data:
Excel Data Sheet
I'm wanting it to keep rows 2 - 11 as they all contain something in K, L or M. The current code that I found and have been trying to use seems to only be recognising columns L and M because it is deleting row 2 which has a figure in column K. I don't want it to calculate the totals of the 3 cells in a row because if I have a figure of $500 in column K and -$500 in column L, they'll equal to $0.00 but I need that row because there is data.
I had found 2 questions very similar to what I'm asking on this site so I tried to apply the code to what I'm doing but I must have been doing something wrong because I couldn't get it to work.
Excel VBA delete entire row if both columns B and C are blank
Delete entire row if cells in specific range are all empty
This is the code that I found and have been trying to use. Could it not be working because 1 column is positive numbers and the other 2 are negative numbers? I'm really new to using VBA etc. so I'm sorry if this is something really simple.
Sub DeleteRows()
Dim rng As Range, cel As Range
Dim N As Long
For N = rng.Rows.Count To 1 Step -1
If rng.Cells(N, 1) = 0 And rng.Cells(N, 2) = 0 Then
rng.Cells(N, 1).EntireRow.Delete shift:=xlShiftUp
End If
Set rng = ActiveSheet.Range("L1:L" & ActiveSheet.Range("L" & ActiveSheet.Rows.Count).End(xlUp).Row)
If rng.Cells(N, 1) = 0 And rng.Cells(N, 2) = 0 Then
rng.Cells(N, 1).EntireRow.Delete shift:=xlShiftUp
End If
Set rng = ActiveSheet.Range("M1:M" & ActiveSheet.Range("M" & ActiveSheet.Rows.Count).End(xlUp).Row)
If rng.Cells(N, 1) = 0 And rng.Cells(N, 2) = 0 Then
rng.Cells(N, 1).EntireRow.Delete shift:=xlShiftUp
End If
Next N
End Sub
The spread sheets that I actually work with and use every day usually contain 12,000 to 15,000 rows (file size is always about 2.5MB).
I would really appreciate any help on what I could do to make this work.
Thank you
If I understand you correctly:
Sub DeleteRows()
Dim rw As Range, r
'start on the last row
With ActiveSheet.Range("A1").CurrentRegion.EntireRow
Set rw = .Rows(.Rows.Count)
End With
Do While rw.Row > 11
r = Application.CountIf(rw.Cells(1, "K").Resize(1, 3), 0)
Set rw = rw.Offset(-1, 0)
If r = 3 Then rw.Offset(1, 0).Delete
Loop
End Sub
you may want to try this code:
Option Explicit
Sub DeleteRows()
With ActiveSheet '<--| refer to active sheet (you may want to explicitly refer to a named worksheet: 'With Worksheets("mySheet")')
With .Range("A1").CurrentRegion.Offset(, .UsedRange.Columns.Count).Resize(, 1) '<--| refer to a range in a "helper" column just outside the used range occupying the same rows as your data
.FormulaR1C1 = "=if(countif(RC11:RC13,0)=3,1,"""")" '<--| use "helper" column to mark "KLM-zero's" rows with a "1", while leaving others with a "blank" mark
If WorksheetFunction.Sum(.Cells) > 0 Then .SpecialCells(XlCellType.xlCellTypeFormulas, xlNumbers).EntireRow.Delete '<--| delete any row whose "helper" column cell is marked with "1"
.Clear '<--| clear "helper" column
End With
End With
End Sub
I am trying to come up with a lean and error-proofed macro to delete rows containing duplicate values in a column A. I have two solutions and both have their advantages. None of them are exactly what I want.
I need rows containing duplicates deleted but leaving the last row that contained the duplicate.
This one is awesome. It has no loop and works instantaneously. The problem is that it deletes subsequent rows containing duplicates hence leaving the first occurrence of the duplicate (And I need the last/ or second - most show up only twice)
Sub Delete()
ActiveSheet.Range("A:E").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
This one goes from the bottom and deletes duplicates. It lasts longer than the first one ( I have around 6k rows) But the issue with this one is that it doesnt delete them all. Some duplicates are left and they are deleted after I run the same code again. Even smaller number of duppes is still left. Basically need to run it up to 5 times and then I end up with clean list.
`
Sub DeleteDup()
Dim LastRowcheck As Long, n1 As Long, rowschecktodelete As Long
LastRowcheck = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For n1 = 1 To LastRowcheck
With Worksheets("Sheet1").Cells(n1, 1)
If Cells(n1, 1) = Cells(n1 + 1, 1) Then
Worksheets("Sheet1").Cells(n1, 1).Select
Selection.EntireRow.Delete
End If
End With
Next n1
End Sub
`
Is there a way to improve any of these to work well or is there a better solution? Any info is greatly appreciated. Thanks
The easiest way would be to delete all rows at once. Also to increase speed, you better do your checks with variables and not with the real cell values like this:
Sub DeleteDup()
Dim LastRowcheck As Long
Dim i As Long
Dim rows_to_delete As Range
Dim range_to_check As Variant
With Worksheets("Sheet1")
LastRowcheck = .Cells(Rows.Count, 1).End(xlUp).Row
range_to_check = .Range("A1:A" & LastRowcheck).Values
For i = 1 To LastRowcheck - 1
If range_to_check(i, 1) = range_to_check(i + 1, 1) Then
If rows_to_delete Is Nothing Then
Set rows_to_delete = .Cells(i, 1)
Else
Set rows_to_delete = Union(.Cells(i, 1), rows_to_delete)
End If
End If
Next n1
End With
rows_to_delete.EntireRow.Delete
End Sub
The concept is right, but remember that when you delete rows, Cells(n1 + 1, 1) isn't going to be the same thing as it was before you deleted a row. The solution is to simply reverse the loop and test rows from bottom to top:
Sub DeleteDup()
Dim last As Long
Dim current As Long
Dim sheet As Worksheet
Set sheet = Worksheets("Sheet1")
With sheet
last = .Range("A" & .Rows.Count).End(xlUp).Row
For current = last To 1 Step -1
If .Cells(current + 1, 1).Value = .Cells(current, 1).Value Then
.Rows(current).Delete
End If
Next current
End With
End Sub
Note that you can use the loop counter to index .Rows instead of using the Selection object to improve performance fairly significantly. Also, if you grab a reference to the Worksheet and toss the whole thing in a With block you don't have to continually dereference Worksheets("Sheet1"), which will also improve performance.
If it still runs too slow, the next step would be to flag rows for deletion, sort on the flag, delete the entire flagged range in one operation, then sort back to the original order. I'm guessing the code above should be fast enough for ~6K rows though.
This question already has answers here:
Excel VBA deleting rows in a for loop misses rows
(4 answers)
Closed 4 years ago.
I have been coding a macro in Excel that scans through a list of records, finds any cells with "CHOFF" in the contents, copying the row that contains it, and pasting those cells into another sheet. It is part of a longer code that formats a report.
It has worked just fine, except that the "For Each" loop has been skipping over some of the entries seemingly at random. It isn't every other row, and I have tried sorting it differently, but the same cells are skipped regardless, so it doesn't seem to be about order of cells. I tried using InStr instead of cell.value, but the same cells were still skipped over.
Do you have any idea what could be causing the code just not to recognize some cells scattered within the range?
The code in question is below:
Dim Rng As Range
Dim Cell As Range
Dim x As Integer
Dim y As Integer
ActiveWorkbook.Sheets(1).Select
Set Rng = Range(Range("C1"), Range("C" & Rows.Count).End(xlUp))
x = 2
For Each Cell In Rng
If Cell.Value = "CHOFF" Then
Cell.EntireRow.Select
Selection.Cut
ActiveWorkbook.Sheets(2).Select
Rows(x).Select
ActiveWorkbook.ActiveSheet.Paste
ActiveWorkbook.Sheets(1).Select
Selection.Delete Shift:=xlUp
y = x
x = y + 1
End If
Next Cell
The For Each...Next loop doesn't automatically keep track of which rows you have deleted. When you delete a row, Cell still points to the same address (which is now the row below the original one, since that was deleted). Then on the next time round the loop, Cell moves onto the next cell, skipping one.
To fix this, you could move Cell up one within the If statement (e.g. with Set Cell = Cell.Offset(-1,0)). But I think this is one of the rare cases where a simple For loop is better than For Each:
Dim lngLastRow As Long
Dim lngSourceRow As Long
Dim lngDestRow As Long
Dim objSourceWS As Worksheet
Dim objDestWS As Worksheet
Set objSourceWS = ActiveWorkbook.Sheets(1)
Set objDestWS = ActiveWorkbook.Sheets(2)
lngLastRow = objSourceWS.Range("C" & objSourceWS.Rows.Count).End(xlUp).Row
lngDestRow = 1
For lngSourceRow = lngLastRow To 1 Step -1
If objSourceWS.Cells(lngSourceRow, 3).Value = "CHOFF" Then
objSourceWS.Rows(lngSourceRow).Copy Destination:=objDestWS.Cells(lngDestRow, 1)
objSourceWS.Rows(lngSourceRow).Delete
lngDestRow = lngDestRow + 1
End If
Next lngSourceRow
This loops backwards (as per Portland Runner's suggestion) to avoid having to do anything about deleted rows. It also tidies up a couple of other things in your code:
You don't need to do any Selecting, and it's better not to (see this question for why)
You can specify a destination within Range.Copy rather than having to do a separate select and paste
You can change the value of a variable "in place" without having to assign it to a second variable first (i.e. x = x + 1 is fine)
you should use Long rather than Integer for variables that contain row numbers, since there are more rows in an Excel spreadsheet than an Integer can handle (at least 65536 compared to 32767 max for an Integer)
Obviously test that it still does what you require!
Try using Selection.Copy instead of Selection.Cut
If you have to remove those lines you can mark the lines (for example writing something in an unused cell) inside the loop and then remove it once finished the main loop.
Regards
I had a similar issue when I was trying to delete certain rows. The way I overcame it was by iterating through the loop several times using the following:
For c = 1 To 100
Dim d As Long: d = 1
With Sheets("Sheet")
For e = 22 To nLastRow Step 1
If .Range("G" & e) = "" Or .Range("I" & e) = "" Then
.Range("G" & e).EntireRow.Delete
.Range("I" & e).EntireRow.Delete
d = d + 1
End If
Next
End With
c = c + 1
Next
So, basically if you incorporate the outer for loop from my code into your code, it should work.