Compare 2 cells in 2 different ranges if they match delete whole row - excel

I am trying to delete rows where the same value occurs in both columns C and D on the same row
I am comparing between column C(BOS address 1) and D (Empower address 1)so if they have the same string remove the whole row. The code is below it executes normally but give Object 424 error after it runs.
Sub test()
Dim try As String
Dim lastrow As Long
Dim x As Variant
Dim row_count As Long
Dim lastrow_str As String
Dim lastrow_rng As String
With empower_report
' Get count of records to search through (list that will be deleted)'
lastrow_str = getColStr("Empower Address 1")
lastrow = Cells(Rows.Count, lastrow_str).End(xlUp).Row
lastrow_rng = getColRange("BOS Address 1")
' Loop through the "master" list'
For Each x In Range(lastrow_rng)
' Loop through all records in the second list.
For row_count = lastrow To 1 Step -1
' Do comparison of next record'
If x.Value = Cells(row_count, 4).Value Then
' If match is true then delete row.
Cells(row_count, 4).EntireRow.Delete
End If
Next row_count
Next
End With
End Sub
The error message ( 424 object required) because of this line. once I press end the code will run.
If x.Value = Cells(row_count, 4).Value Then
Example : input: Column C D
denver denver
denver boston
Output: Column C D
denver boston
I don't have a lot of VBA experience yet. Thank you

since you are trying to delete rows where the same value occurs in both columns C and D on the same row, you only need one loop.
Sub Demo()
Dim FirstDataColumn As Range
Dim SecondDataColumn As Range
Dim i As Long
With empower_report
' get reference to column data by any means you choose
Set FirstDataColumn = .Range( ... )
Set SecondDataColumn = .Range( ... )
If FirstDataColumn.Row <> SecondDataColumn.Row Then
' ranges are not aligned
Exit Sub
End If
If FirstDataColumn.Rows.Count <> SecondDataColumn.Rows.Count Then
' ranges are not the same size
Exit Sub
End If
' Loop the array
For i = FirstDataColumn.Rows.Count To 1 Step -1
' Detect if items on same row are equal
If FirstDataColumn.Cells(i, 1) = SecondDataColumn.Cells(i, 1) Then
' Delete row
FirstDataColumn.Rows(i).EntireRow.Delete
End If
Next
End With
End Sub
Note that this will be slower than it can be because:
Loop ranges is slow
Deleting rows one at a time is slow
If your data sets are small enough this may not be noticable.
On the other hand, if it's too slow for you, then you could
Move the data to a variant array and loop that
Collect a reference to rows to be deleted as you loop, then delete all rows in one go at the end

Remove Duplicates (Loop Column Range)
This is kind of a range study i.e. it surely can be done to be more elegant and more efficient e.g. if you could determine the whole range first, you could use RemoveDuplicates when possible data to the left and/or to the right would not be affected.
Option Explicit
Sub RemoveDupesLoop()
Const Title1 As String = "Empower Address 1"
Const Title2 As String = "BOS Address 1"
Const tRow As Long = 1 ' Title (Header) Row
Dim rg1 As Range
Dim Col2 As Long
With empower_report
Dim cIndex As Variant
cIndex = Application.Match(Title1, .Rows(tRow), 0)
If IsError(cIndex) Then Exit Sub
Dim Col1 As Long: Col1 = cIndex
cIndex = Application.Match(Title2, .Rows(tRow), 0)
If IsError(cIndex) Then Exit Sub
Col2 = cIndex
Dim lRow1 As Long: lRow1 = .Cells(.Rows.Count, Col1).End(xlUp).Row
If lRow1 <= tRow Then Exit Sub
Dim lRow2 As Long: lRow2 = .Cells(.Rows.Count, Col2).End(xlUp).Row
If lRow2 <= tRow Then Exit Sub
Dim lRow As Long
If lRow1 < lRow2 Then
lRow = lRow1
Else
lRow = lRow2
End If
Set rg1 = .Range(.Cells(tRow + 1, Col1), .Cells(lRow, Col1))
End With
Dim drg As Range
Dim cCell As Range
For Each cCell In rg1.Cells
If cCell.Value = cCell.EntireRow.Cells(Col2).Value Then
If drg Is Nothing Then
Set drg = cCell
Else
Set drg = Union(drg, cCell)
End If
End If
Next cCell
If Not drg Is Nothing Then
drg.EntireRow.Delete
End If
End Sub

Related

how to suppress efficiently all empty rows in selected columns in excel vba?

I have found some Q/A to delete rows with empty cells in a chosen column like here. My need is a bit different, the columns are selected by the user, but this is not important.
EDIT : what is important in my use case is to delete the rows where all the cells are empty for these columns i.e. the selected columns.
The following code is working, but can only process 1,000 lines per minute on my i5. In my use case, the datasheet contains several 100k lines which means hours to process. This is not acceptable. Is there a trick to perfom it quickly please?
Sub DeleteRowsOfEmptyColumn() 'sh As Worksheet, col As String)
Application.ScreenUpdating = False
Dim sh As Excel.Worksheet: Set sh = ActiveWorkbook.ActiveSheet
Dim col As Range: Set col = Selection.EntireColumn
Dim cell
Dim area As Range: Set area = Intersect(sh.UsedRange, col)
For i = area.Rows.Count To 1 Step -1 'For Each row In area.Rows
fKeep = False
For Each cell In area.Rows(i).Cells
If Not IsEmpty(cell) Then
fKeep = True
Exit For
End If
Next cell
If Not fKeep Then
sh.Rows(i).Delete 'rowsToDelete.Add i
End If
Next i
Application.ScreenUpdating = True
End Sub
Example:
Before:
After:
Delete Empty Row Ranges
This is a basic example. Your feedback regarding the efficiency is appreciated.
Option Explicit
Sub DeleteRowsOfEmptyColumn()
Application.ScreenUpdating = False
Dim ws As Worksheet: Set ws = ActiveSheet ' improve
Dim crg As Range: Set crg = Selection.EntireColumn ' Columns Range
Dim srg As Range: Set srg = Intersect(ws.UsedRange, crg) ' Source Range
Dim drg As Range ' Delete Range
Dim arg As Range ' Area Range
Dim rrg As Range ' Row Range
For Each arg In srg.Areas
For Each rrg In arg.Rows
If Application.CountA(rrg) = 0 Then
If drg Is Nothing Then
Set drg = rrg
Else
Set drg = Union(drg, rrg)
End If
End If
Next rrg
Next arg
If Not drg Is Nothing Then drg.Delete
Application.ScreenUpdating = True
MsgBox "Rows deleted.", vbInformation
End Sub
Please, try the next way. It will process selected columns or columns having at least a selected cell. It will delete entire rows of the sheet, for the cases of all selected columns empty rows. The code only selects the rows in discussion. If they are the appropriate ones, on the last code line, Select should be replaced with Delete. It should be very fast, even for larger ranges, iterating only between blank cells range:
Sub DeleteRowsOfEmptyColumnsCells()
Dim sh As Excel.Worksheet: Set sh = ActiveSheet
Dim col As Range: Set col = Selection.EntireColumn
Dim area As Range: Set area = Intersect(sh.UsedRange, col)
Dim firstCol As Long: firstCol = area.Column: Stop
Dim areaV As Range, arr, rngDel As Range, i As Long
On Error Resume Next 'only for the case of no any empty rows existence
Set areaV = area.SpecialCells(xlCellTypeBlanks) 'a range of only empty cells
On Error GoTo 0
arr = getRows(areaV) 'extract all rows and number of columns
For i = 0 To UBound(arr(0)) 'iterate between all existing rows
If Intersect(sh.rows(arr(0)(i)), areaV).cells.count = arr(1) Then
If rngDel Is Nothing Then
Set rngDel = sh.cells(arr(0)(i), firstCol)
Else
Set rngDel = Union(rngDel, sh.cells(arr(0)(i), firstCol))
End If
End If
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Select 'if it looks OK, Select should be replaced with Delete
End Sub
Function getRows(rng As Range) As Variant
Dim A As Range, i As Long, countC As Long
Dim arrCol, arrR, k As Long, R As Long, mtchC, mtchR
ReDim arrCol(rng.cells.count): ReDim arrR(rng.cells.count)
For Each A In rng.Areas
For i = 1 To A.Columns.count
For j = 1 To A.rows.count
mtchC = Application.match(A.cells(j, i).Column, arrCol, 0)
mtchR = Application.match(A.cells(j, i).row, arrR, 0)
If IsError(mtchC) Then
arrCol(k) = A.cells(j, i).Column: k = k + 1
End If
If IsError(mtchR) Then
arrR(R) = A.cells(j, i).row: R = R + 1
End If
Next j
Next i
Next A
ReDim Preserve arrR(R - 1)
getRows = Array(arrR, k)
End Function
I am working on similar kind of project. I have chosen to read the data into an array, and then work with the data in the array which improves run time significantly. Here is a copy of the function that I have used to delete / transform the data set:
Option Explicit
Option Base 1
Public Function RemoveRowFromArray(Arr As Variant, Element As String, Col As Long) As Variant
Dim i, j, c, count As Long
Dim TempArr() As Variant
For i = LBound(Arr, 1) To UBound(Arr, 1) ' looping through the columns to get desired value
If Arr(i, Col) = Element Then
count = count + 1 ' Counting the number of Elements in array / matrix
For j = i To (UBound(Arr, 1) - 1) ' Looping from the row where Element is found
For c = LBound(Arr, 2) To UBound(Arr, 2) ' Moving all elements in row 1 row up
Arr(j, c) = Arr(j + 1, c)
Next c
Next j
End If
Next i
' Populating TempArr to delete the last rows
ReDim TempArr((UBound(Arr, 1) - count), UBound(Arr, 2))
For i = LBound(TempArr, 1) To UBound(TempArr, 1)
For j = LBound(TempArr, 2) To UBound(TempArr, 2)
TempArr(i, j) = Arr(i, j)
Next j
Next i
RemoveRowFromArray = TempArr
End Function
I tested this and seems to work perfectly. A few important matters to keep in mind
Option Base 1 - This is important, when you declare an arr in VBA it starts at Index 0, when you read the arr from a data set in Excel [arr = sheet1.Range("A:D")] then the arr starting index is 1, Option Base 1 will ensure that all arr start at Index 1.
The function variables are :
Arr - the array / matrix
Element - the string that you wish to search for (in your case it would be blank)
Col - is the column number in which Element is.

Search for a match, copy entire row, and paste to corresponding

Col B on "Sheet2" contains 370 rows of data.
Starting with "Sheet2" Cell B1, I want to search for a matching value in Col B on "Sheet1" (it could be located anywhere in the first 300 rows of "Sheet1" Col B).
If a match is found, copy the entire row from "Sheet1" and paste to Row1 on "Sheet2". Then, move to "Sheet2" Cell B2 and repeat the search, this time pasting the entire row from "Sheet1" to Row2 on "Sheet2". Continue moving thru the entire column of data on "Sheet2", searching for each cell's value on "Sheet1". If a search doesn't return a match, then do not paste anything to that row on "Sheet2" and just proceed to search for the next cell on "Sheet2". (For example, if Sheet1 Col B doesn't contain a match for Sheet2 Cell B3, then nothing gets pasted in Sheet2 Row3.)
I have found the following example, which starts to help me, but it specifies the search value and doesn't loop thru the entire column of values like I am attempting to do.
Sub CopyYes()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Sheet1")
Set Target = ActiveWorkbook.Worksheets("Sheet2")
J = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("E1:E1000") ' Do 1000 rows
If c = "yes" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
This should do the trick, and do it fast:
Option Explicit
Sub CopyYes()
'You need Microsoft Scripting Runtime library under Tools-References for this
Dim arrPaste As Variant: arrPaste = Sheet2.UsedRange.Value
Dim arrCopy As Variant: arrCopy = Sheet1.UsedRange.Value
Dim MyMatches As New Dictionary: Set MyMatches = CreateDictionary(arrCopy)
Dim i As Long
For i = 1 To UBound(arrPaste)
If arrPaste(i, 2) = vbNullString Then Exit For
If MyMatches.Exists(arrPaste(i, 2)) Then PasteData arrPaste, arrCopy, i, MyMatches(arrPaste(i, 2))
Next i
Sheet2.UsedRange.Value = arrPaste
Erase arrCopy
Erase arrPaste
End Sub
Private Function CreateDictionary(arr As Variant) As Dictionary
Dim i As Long
Set CreateDictionary = New Dictionary
For i = 1 To 300
CreateDictionary.Add arr(i, 2), i
Next i
End Function
Private Sub PasteData(arrPaste As Variant, arrCopy As Variant, i As Long, MyMatch As Long)
Dim j As Long
For j = 1 To UBound(arrCopy, 2)
If arrCopy(MyMatch, j) = vbNullString Then Exit For
arrPaste(i, j) = arrCopy(MyMatch, j)
Next j
End Sub
Use Range.Find to search for your matching cell
Use a Union to create a collection of the rows that are found
Once your loop is finished, copy your range all at once if the Union is not empty
Sub Shelter_In_Place()
Dim Source As Worksheet: Set Source = ThisWorkbook.Sheets("Sheet1")
Dim Target As Worksheet: Set Target = ThisWorkbook.Sheets("Sheet2")
Dim Found As Range, lr As Long
Dim CopyMe As Range
lr = Target.Range("B" & Target.Rows.Count).End(xlUp).Row
For i = 1 To lr
Set Found = Source.Range("B:B").Find(Target.Range("B" & i), LookIn:=xlWhole)
If Not Found Is Nothing Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, Target.Range("B" & i))
Else
Set CopyMe = Target.Range("B" & i)
End If
End If
Set Fouund = Nothing
Next i
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy
Source.Range("A1").PasteSpecial xlPasteValues
End If
End Sub

Adding and Setting Ranges in Excel VBA

I have this sample table.
What I am trying to do is to get all the cell values in all colored cells and transpose them to another worksheet.
I have trouble with the code below to add and set those ranges together so that I can transpose all of them in a ROW in the other worksheet. I have started with the code below
Sub AddRanges()
Dim inRange As Range, inRangeValues() As Variant, outRangeValues() As Variant
Dim finalRow As Long
Dim inRange As Range
Set inRange = Sheet1.Range("A1:A6", "C1:C6", C10:C14) 'I think i got this wrong; Error Type Mismatch
inRangeValues() = inRange.Value 'generate 2d array
outRangeValues = Application.Transpose(inRangeValues)
With Sheet2
finalRow = .Cells(Rows.Count, 1).End(xlUp).Row 'find last row
If inRange.Columns.Count > 1 Then '2d array for output
.Cells(finalRow + 1, 1).Resize(UBound(outRangeValues, 1), UBound(outRangeValues, 2)) = outRangeValues 'Resize according to output array dimensions
Else '1D array for output
.Cells(finalRow + 1, 1).Resize(1, UBound(outRangeValues, 1)) = outRangeValues
End If
End With
End sub
In this example, what is the best approach to combine these ranges so I can transpose them as a ROW? Thanks.
Your code has major problems due to:
Double declaration of inRange
Wrong syntax for Set inRange the entire address needs to be enclosed in a single pair of quotes
Try Set inRange = Range("a1:a6, c1:c6, c10:c14")
Wrong method of reading into an array
When you have a range that consists of multiple areas, you have to convert each area separately.
Then you can create a 1-D array from this depending on the order you wish to have these elements, and write it wherever you want.
For example:
Option Explicit
Sub test()
Dim inRange As Range, inRangeValues As Variant, outRangeValues As Variant
Dim finalRow As Long
Dim I As Long, J As Long, V As Variant, L As Long
Dim lCols As Long
Set inRange = Range("a1:a6, c1:c6, c10:c14")
ReDim inRangeValues(1 To inRange.Areas.Count)
For I = 1 To inRange.Areas.Count
inRangeValues(I) = inRange.Areas(I)
Next I
'how many columns?
lCols = 0
For I = 1 To UBound(inRangeValues, 1)
lCols = lCols + UBound(inRangeValues(I), 1)
Next I
ReDim outRangeValues(1 To lCols)
L = 0
For I = 1 To UBound(inRangeValues, 1)
For J = 1 To UBound(inRangeValues(I), 1)
L = L + 1
outRangeValues(L) = inRangeValues(I)(J, 1)
Next J
Next I
Stop
' enter some code to write the results where you want
' below is just throwaway for proof of concept
Range("f20").Resize(columnsize:=UBound(outRangeValues)).Value = outRangeValues
End Sub
Given your input, the above code would create output like:
You are correct that your code is wrong where you highlight. Try a union. From there, it should be pretty basic to just loop through your range and put them wherever you want in the Sheet2 spreadsheet. See if the below does what you need.
Sub AddRanges()
Dim inRange As Range, acell As Range, aCounter As Long
Const startAddress As String = "A1"
Set inRange = Union(Sheet1.Range("A1:A6"), Sheet1.Range("C1:C6"), Sheet1.Range("C10:C14"))
For Each acell In inRange.Cells
If Not IsEmpty(acell) Then
finalRow = sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1 'find last row
sheet2.Cells(finalRow, 1).Value = acell.Value
End If
Next acell
End Sub
Check it out.
Sub RngAreaTransps()
Dim RangeArea As Range, LstRw As Long
Dim sh As Worksheet, ws As Worksheet
Dim col As Long, InRange As Range
Set sh = Sheets(1)
Set ws = Sheets(2)
LstRw = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
With sh
Set InRange = .Range("A1:A6, C1:C6, C10:C14")
For Each RangeArea In InRange.Areas
With ws
col = .Cells(LstRw, .Columns.Count).End(xlToLeft).Column
If col <> 1 Then col = col + 1
RangeArea.SpecialCells(xlCellTypeConstants).Copy
.Cells(LstRw, col).PasteSpecial Transpose:=True
End With
Next RangeArea
End With
Application.CutCopyMode = False
End Sub

Iterate over all rows and find the empty ones of active sheet VBA

I have an Excel-worksheet with different "sections" separated by an empty row. What I want to do is to simple get the row numbers to work with them. Sadly the code is not executing the For-Loop (No failure, just not entering it) but the rowNumber variable is set properly. Did I miss something on the For-Loop?
Sub Foo()
Dim currentSheet As Worksheet
Set currentSheet = activeSheet
emptyRows = FindAllEmptyRows(currentSheet)
End Sub
Function FindAllEmptyRows(sheet As Worksheet) As Variant
Dim emptyRows() As Variant
Dim i As Long, rowNumber As Long
Dim rowCounter As Integer
rowCounter = 1
rowNumber = sheet.UsedRange.Rows.Count
For i = rowNumber To 1
If Cells(i, 1).End(xlToRight).Column = 16384 And Cells(i, 1) = "" Then
emptyRows(rowCounter) = i
rowCounter = rowCounter + 1
End If
Next
FindAllEmptyRows = emptyRows
End Function
If you want to iterate from last row to first you will need to add Step -1.
emptyRows() needs to be sized to fit the data using ReDim
.Column = 16384 should be changed to .Column = sheet.Columns.Count.
I prefer If WorksheetFunction.CountA(sheet.Rows(i)) = 0 Then
Cells needs to be qualified to sheet: sheet.Cells(i, 1)
Refactored Code
Function FindAllEmptyRows(sheet As Worksheet) As Variant
Dim emptyRows() As Variant
Dim i As Long, rowNumber As Long
Dim rowCounter As Integer
rowNumber = sheet.UsedRange.Rows.Count
For i = rowNumber To 1 Step -1
If sheet.Cells(i, 1).End(xlToRight).Column = sheet.Columns.Count And Cells(i, 1) = "" Then
If rowCounter = 0 Then
ReDim emptyRows(0)
Else
ReDim Preserve emptyRows(rowCounter)
End If
emptyRows(rowCounter) = i
rowCounter = rowCounter + 1
End If
Next
FindAllEmptyRows = emptyRows
End Function
SpecialCells
Range.SpecialCells() can be used to divide a Range into areas of cells that meet certain criteria.
MSDN - Range.SpecialCells Method (Excel)
Returns a Range object that represents all the cells that match the specified type and value
OZ Grid
One of the most beneficial Methods in Excel (in my experience) is the SpecialCells Method. When used, it returns a Range Object that represents only those type of cells we specify. For example, one can use the SpecialCells Method to return a Range Object that only contains formulae. In fact, we can, if we wish, even narrow it down further to have our Range Object (containing only formulae) to return only formulae with errors.
Examining the output of this code should give you a good ideas of how to use SpecialCells.
Sub SpecialFoo()
Dim rArea As Range, rBlanks As Range, rFormulas As Range, rConstants As Range, rUnion As Range
Dim sheet As Worksheet
Set sheet = ActiveSheet
On Error Resume Next
Set rBlanks = sheet.UsedRange.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rBlanks Is Nothing Then
For Each rArea In rBlanks.Areas
Debug.Print "rBlanks Areas: "; rArea.Address
Next
End If
On Error Resume Next
Set rFormulas = sheet.UsedRange.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rFormulas Is Nothing Then
For Each rArea In rFormulas.Areas
Debug.Print "rFormulas Areas: "; rArea.Address
Next
End If
On Error Resume Next
Set rConstants = sheet.UsedRange.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rConstants Is Nothing Then
For Each rArea In rConstants.Areas
Debug.Print "rConstants Areas: "; rArea.Address
Next
End If
If Not rFormulas Is Nothing And Not rConstants Is Nothing Then
Set rFormulas = Union(rConstants, rFormulas)
For Each rArea In rFormulas.Areas
Debug.Print "rUnion Areas: "; rArea.Address
Next
End If
End Sub
you have to size emptyRows() before using it
furthermore you could use WorksheetFunction.Count() to check for any value in current row
finally
Function FindAllEmptyRows(sheet As Worksheet) As Variant
Dim emptyRows() As Variant
Dim i As Long, rowNumber As Long, rowCounter As Long
With sheet.UsedRange ' reference passed sheet UsedRange
rowNumber = .Rows.Count
ReDim emptyRows(0 To rowNumber - 1) ' dim the array to the maximum possible size
For i = rowNumber To 1 Step -1 ' step through reference range rows from the last baxkwards to the first
If WorksheetFunction.Count(.Rows(i)) = 0 Then
emptyRows(rowCounter) = i + .Rows(1).Row - 1 ' fill array in current index with current row index
rowCounter = rowCounter + 1 ' update array index
End If
Next
End With
ReDim Preserve emptyRows(0 To rowCounter) ' redim the array according to the actual number of found empty rows
FindAllEmptyRows = emptyRows
End Function
please note that:
emptyRows(rowCounter) = i + .Rows(1).Row - 1
is storing the absolute row index, i.e. the sheet row index, while
emptyRows(rowCounter) = i
would store the relative row index, i.e. the row index withing the UsedRange, which may start from a row different than row 1

Excel - Move rows containing an empty cell to another sheet

This is my first attempt at VBA, so I apologize for my ignorance. The situation is as follows: I have a spreadsheet that consists of 4 columns and 629 rows. When I am trying to do is iterate through the 4 cells in each row and check for a blank cell. If there is a row that contains a blank cell, I want to cut it from Sheet1 and paste it into the first available row in Sheet2.
(Ideally the number of columns AND the number of rows is dynamic based on each spreadsheet, but I have no idea how to iterate through rows and columns dynamically)
Sub Macro1()
'
' Macro1 Macro
' Move lines containing empty cells to sheet 2
'
' Keyboard Shortcut: Ctrl+r
'
Dim Continue As Boolean
Dim FirstRow As Long
Dim CurrentRow As Long
Dim LastRow As Long
Dim EmptySheetCount As Long
Dim Counter As Integer
'Initialize Variables
LContinue = True
FirstRow = 2
CurrentRow = FirstRow
LastRow = 629
EmptySheetCount = 1
'Sheets(Sheet1).Select
'Iterate through cells in each row until an empty one is found
While (CurrentRow <= LastRow)
For Counter = 1 To 4
If Sheet1.Cells(CurrentRow, Counter).Value = "" Then
Sheet1.Cells(CurrentRow).EntireRow.Cut Sheet2.Cells(EmptySheetCount, "A")
EmptySheetCount = EmptySheetCount + 1
Counter = 1
CurrentRow = CurrentRow + 1
GoTo BREAK
Else
Counter = Counter + 1
End If
Counter = 1
BREAK:
Next
Wend
End Sub
When I run it, I typically get an error around the Sheet1.Cells(CurrentRow, Counter).Value = "" area, so I know I'm referencing sheets incorrectly. I've tried Sheets(Sheet1), Worksheets("Sheet1") and nothing seems to be working. When I do change to Worksheets("Sheet1"), however, it runs and just freezes Excel.
I know I'm doing multiple things wrong, I just know way too little to know what.
Thanks a lot in advance. And sorry for the crap formatting.
There are a few things wrong with your code so rather than go through them individually here is a basic looping version that does what you're after.
Sub moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Dim lastColumn As Integer
Dim lastRow As Integer
Dim destinationRow As Integer
Set wksData = Worksheets("Sheet1")
Set wksDestination = Worksheets("Sheet2")
destinationRow = 1
lastColumn = wksData.Range("XFD1").End(xlToLeft).Column
lastRow = wksData.Range("A1048576").End(xlUp).Row
For i = lastRow To 1 Step -1 'go 'up' the worksheet to handle 'deletes'
For j = 1 To lastColumn
If wksData.Cells(i, j).Value = "" Then 'check for a blank cell in the current row
'if there is a blank, cut the row
wksData.Activate
wksData.Range(Cells(i, 1), Cells(i, lastColumn)).Cut
wksDestination.Activate
wksDestination.Range(Cells(destinationRow, 1), Cells(destinationRow, lastColumn)).Select
ActiveSheet.Paste
'If required this code will delete the 'cut' row
wksData.Rows(i).Delete shift:=xlUp
'increment the output row
destinationRow = destinationRow + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next j
Next i
set wksData = Nothing
set wksDestination = Nothing
End Sub
There are other ways that will achieve the same outcome but this should give you and idea of how to use loops, sheets, ranges, etc.
The lastColumn and lastRow variables will find the the last column/row of data in the given columns/rows (i.e, in my code it finds the last column of data in row 1, and the last row of data in column A).
Also, you should get into the habit of debugging and stepping through code to identify errors and see exactly what each line is doing (this will also help you learn too).
You might find this of use.
It uses an array variable to store the values of the cells in the row to be moved. It does not use cut and paste, so only transfer the data values, and the code does not require activation of the required sheets.
The destination rows are in the same order as the rows on the original sheet.
The method used to find the last cell used in the row and column is more elegant than other answers given.
Option Explicit
Public Sub test_moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Set wksData = shtSheet1 ' Use the Codename "shtSheet1" for the worksheet. ie the value of the sheet property that is displayed as "(Name)"
Set wksDestination = shtSheet2
moveData wksData, wksDestination
End Sub
Public Sub moveData(wksData As Worksheet, wksDestination As Worksheet)
Dim ilastColumn As Integer
Dim ilastRow As Integer
Dim iRow As Long
Dim iColumn As Long
Dim iDestinationRowNumber As Integer
Dim MyArray() As Variant
Dim rngRowsToDelete As Range
iDestinationRowNumber = 1
ilastColumn = wksData.Cells(1, wksData.Columns.Count).End(xlToLeft).Column
ilastRow = wksData.Cells(wksData.Rows.Count, 1).End(xlUp).Row
ReDim MyArray(1, ilastColumn)
Set rngRowsToDelete = Nothing
For iRow = 1 To ilastRow Step 1 'No need to go 'up' the worksheet to handle 'deletes'
For iColumn = 1 To ilastColumn
If wksData.Cells(iRow, iColumn).Value = "" Then 'check for a blank cell in the current row
MyArray = wksData.Range(wksData.Cells(iRow, 1), wksData.Cells(iRow, ilastColumn)).Value
wksDestination.Range(wksDestination.Cells(iDestinationRowNumber, 1),
wksDestination.Cells(iDestinationRowNumber, ilastColumn) _
).Value = MyArray
'Store the rows to be deleted
If rngRowsToDelete Is Nothing Then
Set rngRowsToDelete = wksData.Rows(iRow)
Else
Set rngRowsToDelete = Union(rngRowsToDelete, wksData.Rows(iRow))
End If
'increment the output row
iDestinationRowNumber = iDestinationRowNumber + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next iColumn
Next iRow
If Not rngRowsToDelete Is Nothing Then
rngRowsToDelete.EntireRow.Delete shift:=xlUp
End If
Set rngRowsToDelete = Nothing
Set wksData = Nothing
Set wksDestination = Nothing
End Sub
' enjoy

Resources