I have the code that in general works but it takes forever to run it - I always need to to break it by pressing 'Esc' becuase otherwise I could wait all day long. When I do press 'Esc' the code in general exceutes what it should. But it is annoying and I would like to have it work smoothly.
My code is supposed to execute simple Index formula in one column until then end of the table (i.e.match some word in the other sheet based on the column in front and return it as the result), then it should copy and paste the content in that column to make the formula disappear and leave only the returned values.
Option Explicit
Sub Match_CopyPaste()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim r As Long
Dim endRow As Long
Dim TargetRow As Long
Const ColumnStart As Integer = 2
Const ColumnEnd As Integer = 2
TargetRow = 4
With ThisWorkbook.Sheets("Sheet1")
'*********Clear what is inside********'
.Range(.Cells(TargetRow, ColumnStart), .Cells(.Rows.Count, ColumnEnd)).ClearContents
.Range("A4", .Cells(Rows.Count, "A").End(xlUp)).Offset(0, 1).FormulaR1C1 = "=IFERROR(INDEX(Array,MATCH(RC[-1],Name,0),2),"""")"
End With
'***Part where the problem is:*******
With ThisWorkbook.Sheets("Sheet1")
'************** Copy and paste it as values*********
endRow = .Cells(.Rows.Count, ColumnEnd).End(xlUp).Row
For r = 4 To endRow
Cells(r, ColumnEnd).Value = Cells(r, ColumnEnd).Value
Next r
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I will add that it is the second part of the code (Copy and paste it as values) where the code breaks. Is it something in the code, like the order or structure that makes it impossible to fill long column down ?
as per BigBen comment:
With ThisWorkbook.Sheets("Sheet1")
'************** Copy and paste it as values*********
With .Range(.Cells(4, ColumnEnd), .Cells(.Rows.Count, ColumnEnd).End(xlUp))
.Value = .Value
End With
End With
Related
This question already has answers here:
Excel VBA - Delete Rows Based on Criteria
(2 answers)
Closed 4 years ago.
In Excel, I want to delete entire row if a cell is blank.
This should count for A17:A1000.
Running the script it returns the error:
Run-time 1004 error
Method Range of object global failed
If I replace A17:A1000 with A it deletes some rows.
Sub DeleteBlanks()
Dim r As Long
Dim m As Long
Application.ScreenUpdating = False
m = Range("A17:A1000" & Rows.Count).End(xlUp).Row
For r = m To 1 Step -1
If Range("A17:A1000" & r).Value = "" Or Range("A17:A1000" & r).Value = 0 Then
Range("A17:A1000" & r).EntireRow.Delete
End If
Next r
Application.ScreenUpdating = True
End Sub
The main issue in your code is that it is counting wrong.
"A17:A1000" & r does not count the rows up but appends the number r to that string. So eg if r = 500 it will result in "A17:A1000500" but not in "A17:A1500" as you might expected.
To delete all rows where column A has a blank cell you can use
Option Explicit
Public Sub DeleteRowsWithBlankCellsInA()
Worksheets("Sheet1").Range("A17:A1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
This one deletes all blank lines at once and therefore is pretty fast. Also it doesn't need to disable ScreenUpdating because it is only one action.
Or if blank and zero cells need to be deleted use
Option Explicit
Public Sub DeleteRowsWithBlankOrZeroCellsInA()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'define which worksheet
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = LastRow To 1 Step -1
If ws.Cells(iRow, "A").Value = vbNullString Or ws.Cells(iRow, "A").Value = 0 Then
ws.Rows(iRow).Delete
End If
Next iRow
End Sub
This one deletes line by line. Each delete action takes its time so it takes longer the more lines you delete. Also it might need to disable ScreenUpdating otherwise you see the line-by-line action.
An alternative way is to collect all the rows you want to delete with Union() and then delete them at once.
Option Explicit
Public Sub DeleteRowsWithBlankOrZeroCellsInA()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'define which worksheet
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim DeleteRange As Range
Dim iRow As Long
For iRow = LastRow To 1 Step -1 'also forward looping is possible in this case: For iRow = 1 To LastRow
If ws.Cells(iRow, "A").Value = vbNullString Or ws.Cells(iRow, "A").Value = 0 Then
If DeleteRange Is Nothing Then
Set DeleteRange = ws.Rows(iRow)
Else
Set DeleteRange = Union(DeleteRange, ws.Rows(iRow)) 'collect rows to delete
End If
End If
Next iRow
DeleteRange.Delete 'delete all at once
End Sub
This is also pretty fast because you have again only one delete action. Also it doesn't need to disable ScreenUpdating because it is one action only.
In this case it is also not necessary to loop backwards Step -1, because it just collects the rows in the loop and deletes at once (after the loop). So looping from For iRow = 1 To LastRow would also work.
There are multiple errors in your code.
First of all, your procedure should have it's scope declared.
Presumably in your case Private
You are incorrectly defining your Range() Please look at its definition
Range.Value = 0 is not the same as Range = "" or better yet IsEmpty(Range)
Looping from beginning to end when deleting individual rows will cause complications (given their indexes [indices(?)] change) - or to better word myself - it is a valid practice, but you should know what you're doing with the indexes. In your case it seems much easier to them them in the LIFO order.
Last but not least, you're unnecessarily complicating your code with certain declarations (not an error so to say, but something to be improved upon)
With all the considered, your code should look something like this:
Option Explicit
Private Sub remove_empty_rows()
Dim ws as Worksheet: Set ws = Sheets("Your Sheet Name")
Dim lr as Long
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim i as Long
For i = lr to 1 Step -1
If IsEmpty(ws.Cells(i, 1)) Then
ws.Rows(i).Delete
End If
Next i
End Sub
In general, without meaning to sound condescending, it looks like you have some learning gaps in your coding practice. I'd refer properly reading some documentation or tutorial first, before actually doing coding like this yourself.
Taking into account that A17 cell is a header, you could use AutoFilter instead of iterating over cells:
Sub FastDeleteMethod()
Dim rng As Range, rngFiltered As Range
Set rng = Range("A17:A" & Cells(Rows.Count, "A").End(xlUp).Row)
With rng
.AutoFilter Field:=1, Criteria1:=0, Operator:=xlOr, Criteria2:="="
On Error Resume Next
Set rngFiltered = rng.SpecialCells(xlCellTypeVisible)
If Err = 0 Then rngFiltered.EntireRow.Delete
On Error GoTo 0
End With
End Sub
I import a lot of Raw data into a sheet "data" and I have another sheet called "Roster" (self-explanatory). I would like to Delete all of the rows in "data" that does not contain any of the names in "Roster". The information in Data is Column J and column A in "roster". I am currently using the code below but it takes a long time.
Sub roster_cleanup()
Const sh1Col As String = "J"
Const sh2Col As String = "A"
Dim ws1 As Worksheet, ws2 As Worksheet
Dim r1 As Long, r2 As Long
Set ws1 = Sheets("Data")
Set ws2 = Sheets("Roster")
r1 = ws1.Cells(Rows.Count, sh1Col).End(xlUp).Row
r2 = ws2.Cells(Rows.Count, sh2Col).End(xlUp).Row
For i = r1 To 2 Step -1
For Each r In ws2.Range(sh2Col & "2:" & sh2Col & r2)
If ws1.Cells(i, sh1Col).Value = r.Value Then GoTo myNext
Next r
ws1.Cells(i, sh1Col).EntireRow.Delete
myNext:
Next i
End Sub
Try adding:
Application.ScreenUpdating = False 'Turn off screen updating. Code runs faster without screen flicker
Application.Calculation = xlManual 'Turns auto calc to manual
at the beginning of your code and :
Application.Calculation = xlAutomatic 'turns auto calc back on
Application.ScreenUpdating = True 'Turn on screen updating
at the end of your code, just before End Sub.
I tackled this problem in the past by adding a 'cheater column' with a vlookup to a remote closed reference list. Then I would place an AutoFilter using VBA on the data, deleting only the visible rows using .SpecialCells(xlCellTypeVisible).EntireRow.Delete ... then clear the helper lookup column. Very fast! Hope this helps and good luck.
I have a worksheet that lists a persons name (column A) with associated data (columns B through G). I have code below that takes this list of a ~ 1000 rows that
A.) First copies and pastes each row three times (to create four identical rows for each entry) then
B.) Loops through the now ~4000 rows and creates a new worksheet for each person.
As there are many duplicate names in column A this only creates ~ ten new worksheets
The thing is, it runs but runs quite slowly (and I receive the Excel not responding warning at times). Is there anything to clean this up to make it more efficient? And after this I run another macro to save the new worksheets to a new workbook. Would it be faster to do that with code here?
Sub Split_Data()
'This will split the data in column A out by unique values
Const NameCol = "A"
Const HeaderRow = 1
Const FirstRow = 2
Dim SrcSheet As Worksheet
Dim TrgSheet As Worksheet
Dim SrcRow As Long
Dim LastRow As Long
Dim TrgRow As Long
Dim person As String
Dim lRow As Long
Dim RepeatFactor As Variant
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Add four rows
lRow = 2
Do While (Cells(lRow, "B") <> "")
RepeatFactor = 4
Range(Cells(lRow, "A"), Cells(lRow, "G")).Copy
Range(Cells(lRow + 1, "A"), Cells(lRow + RepeatFactor - 1, "G")).Select
Selection.Insert Shift:=xlDown
lRow = lRow + RepeatFactor - 1
lRow = lRow + 1
Loop
Set SrcSheet = ActiveSheet
LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
person = SrcSheet.Cells(SrcRow, NameCol).Value
Set TrgSheet = Nothing
On Error Resume Next
Set TrgSheet = Worksheets(person)
On Error GoTo 0
If TrgSheet Is Nothing Then
Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
TrgSheet.Name = person
SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
End If
TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
Next SrcRow
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
first you read the column of names in one pass and put it in an VBA array:
Dim DATA()
with SrcSheet
DATA= .range(.cells(FirstRow, NameCol), .cells(lastRow, namecol)).value2
end with
this gives you a 2D array.
then you create a new scripiting.dictionary , wich fills on a for loop with DATA, and each time a name doesn't exist, you add it to the dictionary.
Dim Dict as new scripting.dictionary 'needs a reference in VBE to : Microsoft Scripting Runtime
dim i& 'long
dim h$ 'string
for i=1 to lastrow-firstrow+1
h=DATA(i,1)
if not dict.exists(h) then
dict(h)=i 'creaates an entry with key=h, item=whatever , here i
end if
next i
You can either create the new worksheets on the fly while adding entries to Dict, or loop later for i=1 to dict.count ...
at the end , you reset all : erase DATA : set Dict=nothing.
Note that this code does not need error handling.
Plz comment on how much time this version needs to do the same task now.
EDIT : your do while looks slow (copy select, insert). If possible B.value2=A.value2 from a range perspective.
I wrote a VBA script to compare fields in excel. Excel freezes the second I click the button. It never displays any error messages. Every time I try to run it I have to use control alt delete to close excel.
one of my variables is commented out because after I get this to work I plan on copying the data to a different sheet instead of changing the font. just an FYI
Private Sub CommandButton4_Click()
Dim rng1, rng2, cell1, cell2 As Range
Set rng1 = Worksheets("Main").Range("B:B")
Set rng2 = Worksheets("CSV Transfer").Range("D:D")
'Set rng3 = Worksheets("Data").Range("A:A")
For Each cell1 In rng1
For Each cell2 In rng2
If IsEmpty(cell2.Value) Then Exit For
If cell1.Value = cell2.Value Then
cell1.Font.Bold = True
cell1.Font.ColorIndex = 2
cell1.Interior.ColorIndex = 3
cell1.Interior.Pattern = xlSolid
cell2.Font.Bold = True
cell2.Font.ColorIndex = 2
cell2.Interior.ColorIndex = 3
cell2.Interior.Pattern = xlSolid
End If
Next cell2
Next cell1
End Sub
Edit: Entire post has been changed to reflect my actual issue.
Your macro isn't freezing, you just aren't giving it enough time to complete - which is a lonnnngggg time. Excel has a row limit of 1,048,576 rows, and you are comparing every single cell in each row to every single cell in the other row. That's a total of 1,099,511,627,776 cell comparisons. Assuming you can do 100,000 comparisons per second (which is probably a stretch even without the formatting), this will eventually complete in just over 127 days.
I'd suggest doing a couple of things. First, when you assign a range to a column like this...
Set rng1 = Worksheets("Main").Range("B:B")
...you get every possible cell - not just the used ones. Find the last non-empty cell in each column, and set your ranges based on that:
Dim LastRow As Long
Dim ColumnB As Range
With Worksheets("Main")
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set ColumnB = .Range("B1:B" + LastRow)
End With
This might get your run times onto the order of minutes or seconds instead of days unless you have a huge data set. To improve them further, stop requesting individual values from the worksheet one at a time and pull them into arrays:
Dim BValues As Variant
BValues = ColumnB.Value
Then, just loop through and compare values in memory. It might look something more like this (I pulled the formatting out into a Sub):
Private Sub CommandButton4_Click()
Dim LastRow As Long, MainSheet As Worksheet, CsvSheet As Worksheet
Set MainSheet = Worksheets("Main")
Set CsvSheet = Worksheets("CSV Transfer")
Dim MainValues As Variant
With MainSheet
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
MainValues = .Range("B1:B" & LastRow).Value
End With
Dim CsvValues As Variant
With CsvSheet
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
CsvValues = .Range("D1:D" & LastRow).Value
End With
Dim MainRow As Long, CsvRow As Long
For MainRow = LBound(MainValues) To UBound(MainValues)
For CsvRow = LBound(CsvValues) To UBound(CsvValues)
If MainValues(MainRow) = CsvValues(CsvRow) Then
FormatCell MainSheet, MainRow, 2
FormatCell CsvValues, CsvRow, 4
End If
Next
Next
End Sub
Private Sub FormatCell(sheet As Worksheet, formatRow As Long, formatCol As Long)
With sheet.Cells(formatRow, formatCol)
With .Font
.Bold = True
.ColorIndex = 2
End With
With .Interior
.ColorIndex = 3
.Pattern = xlSolid
End With
End With
End Sub
I'd also turn off ScreenUpdates at very least if your performance is still too low.
I know this is a pretty basic question, but im still working on building my VBA skills. I am in a predicament where I have made a mapping system of various reports I receive that get placed in a compiled workbook. These reports have entirely different formats etc. I have a copy/paste macro that copies columns and places them in their correct position on the compiled workbook.
I've come into situations however where there are a lot of duplicate / empty rows that screw up my Macro. I have used two VBA functions to solve this, one is a "delete row if reference column is blank":
Sub DeleteBlankARows()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
Dim r As Long
For r = Cells(Rows.Count, 6).End(xlUp).Row To 1 Step -1
If Cells(r, 6) = "" Then Rows(r).Delete
Next r
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With End Sub
This deletes rows where cells in column F are empty
I also use a copy/paste down macro:
Sub CopyUntilBlank()
Dim last_row As Integer
last_row = Range("f1").End(xlDown).Row
Dim rng As Range
Set rng = Range("d2:d" & last_row)
For Each cell In rng.Cells
cell.Activate
If ActiveCell.Value = "" Then
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value
End If
Next cell End Sub
This copies and pastes down blank rows in column D until you hit a non-blank cell then re-does this until the range of values in column F.
These macros work well for me, but because I have multiple sheets like this, I would like to create a cell references that make the ranges dynamic. For instance: in the DeleteBlankRows macro, I would like to have the column reference in Cells(r,6) be determined off of a cell value in sheet1 - so for instance if the value in cell A1 on sheet 1 is 2 it would change the column reference to "2" (column B).
I would like the same to happen for the copy/paste down macro. I'm pretty sure this is just some reference to A1.Value but I don't know how to properly write such thing.
Thank you for your support, I've gone quite a long way with all the support of the community.
An example using your first sub:
Sub DeleteBlankARows(colIndex as Long)
Dim colIndex as long
colIndex = Sheet1.Range("a1").value
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
Dim r As Long
For r = Cells(Rows.Count, colIndex).End(xlUp).Row To 1 Step -1
If Cells(r, colIndex) = "" Then Rows(r).Delete
Next r
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
It's not clear from your question which column in the second sub needs to be dynamic (or both of them?)
EDIT try this:
Sub CopyUntilBlank()
Dim last_row As Long, col1 as Long, col2 as Long
Dim rng as Range
col1 = Sheet1.Range("a2").value
col2 = Sheet1.Range("a3").value
last_row = Cells(1, col1).End(xlDown).Row
'This next line is better if there's any chance
' of blanks in this column
'last_row = Cells(Rows.Count, col1).End(xlUp).Row
With ActiveSheet
Set rng = .Range(.Cells(2, col2), .Cells(last_row, col2))
End With
For Each cell In rng.Cells
If cell.Value = "" Then
cell.Value = cell.Offset(-1, 0).Value
End If
Next cell
End Sub