I have a list of row numbers that I need to keep. All other rows need deleted.
This macro deletes entire rows based on row numbers in a list. It works exactly as intended.
How can it be altered to delete all rows EXCEPT those rows on the list?
Dim deleteRows As Range
Dim data() As Variant
Dim i As Double
Dim SourceWks As Worksheet
Dim oldWks As Worksheet
Set SourceWks = Sheets("TBDws")
Set oldWks = Sheets("TBDsamples")
With SourceWks
data = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
End With
Set deleteRows = oldWks.Rows(data(1, 1))
For i = 2 To UBound(data, 1)
Set deleteRows = Union(deleteRows, oldWks.Rows(data(i, 1)))
Next i
deleteRows.Delete Shift:=xlUp
End Sub
This will delete all the rows on the sheet TBDsamples that aren't listed in column A on TBDws
Sub DeleteThings()
Dim SourceWks As Worksheet
Dim oldWks As Worksheet
Dim deleteRange As Range
Dim arrRows() As Variant
Dim Res As Variant
Dim I As Long
Set SourceWks = Sheets("TBDws")
Set oldWks = Sheets("TBDsamples")
With SourceWks
arrRows = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
End With
For I = 1 To oldWks.Range("A" & Rows.Count).End(xlUp).Row
Res = Application.Match(I, arrRows, 0)
If IsError(Res) Then
If deleteRange Is Nothing Then
Set deleteRange = oldWks.Rows(I)
Else
Set deleteRange = Union(deleteRange, oldWks.Rows(I))
End If
End If
Next I
deleteRange.Delete Shift:=xlUp
End Sub
Related
I found a great solution from this post: Removing duplicate rows after checking all columns
Sub Remove_DuplicateRows()
Dim intArray As Variant, i As Integer
Dim rng As Range
Dim ws As Worksheet
Call Open_Workbook
Set ws = Workbooks("Sales2021.xlsm").Sheets("Reporting Template")
ws.Activate
Set rng = ws.UsedRange.Rows
With rng
ReDim intArray(0 To .Columns.Count - 1)
For i = 0 To UBound(intArray)
intArray(i) = i + 1
Next i
.RemoveDuplicates Columns:=(intArray), Header:=xlYes
End With
End Sub
I tried the script, and wanted to adjust to my case: I want to delete all duplicated rows based on all columns except the first column (i.e., columns B to U). Should I use ws.Range("B2:U3000") instead of UsedRange?
You can either use ws.Range("B2:U3000") or below code
Set rng = ws.UsedRange.Offset(0, 1).Resize(ws.UsedRange.Rows.Count, ws.UsedRange.Columns.Count - 1)
The final code should look like this.
Sub Remove_DuplicateRows()
Dim intArray As Variant, i As Integer
Dim rng As Range
Dim ws As Worksheet
Call Open_Workbook
Set ws = Workbooks("Sales2021.xlsm").Sheets("Reporting Template")
ws.Activate
Set rng = ws.UsedRange.Offset(0, 1).Resize(ws.UsedRange.Rows.Count, ws.UsedRange.Columns.Count - 1)
With rng
ReDim intArray(0 To .Columns.Count - 1)
For i = 0 To UBound(intArray)
intArray(i) = i + 1
Next i
.RemoveDuplicates Columns:=(intArray), Header:=xlYes
End With
End Sub
I am trying to extract listobject filtered data to a new workbook. However, all data is extracted instead of just the filtered data.
Set loop_obj = wsCopy.ListObjects(1)
loop_obj.AutoFilter.ShowAllData
ColNum = Application.WorksheetFunction.Match("DateOrder", wsCopy.Rows(1), 0)
With loop_obj
.Range.AutoFilter Field:=ColNum, Criteria1:=">=0"
End With
'Add Copy Values to Array
Set loop_copy = loop_obj.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
arr = loop_copy.CurrentRegion.Offset(1, 0)
aRws = Evaluate("Row(1:" & UBound(arr) & ")")
arr = Application.Index(arr, aRws, Array(1, 2, 3, 4, 5))
'Create New Workbook with a Blank Worksheet
wb.Worksheets.Add.Move
Set wb_new = ActiveWorkbook
Set wsDest = ActiveWorkbook.ActiveSheet
'Perform Paste Operations
Set loop_paste = wsDest.Range("A1")
loop_paste.Resize(UBound(arr, 1), UBound(arr, 2)).value = arr
With wsDest
.Range(Cells(1, DateNum), Cells(1200, DateNum)).NumberFormat = "[$-en-US]d-mmm-yy;#"
.Parent.SaveAs FileName:=dFilePath, FileFormat:=xlCSVUTF8
.Parent.Close True
End With
loop_obj.AutoFilter.ShowAllData
This worked for me (just copy each column based off the array of column indexes):
Sub tester()
Dim wsCopy As Worksheet, loop_copy As Range
Dim loop_obj As ListObject, colnum As Long
Dim col, visRows As Long, rngDest As Range, i As Long
Set wsCopy = Sheets("Details")
Set loop_obj = wsCopy.ListObjects(1)
loop_obj.AutoFilter.ShowAllData
colnum = Application.Match("DateOrder", loop_obj.HeaderRowRange, 0)
If IsError(colnum) Then
MsgBox "Header not found!"
Exit Sub
End If
Application.ScreenUpdating = False
loop_obj.Range.AutoFilter Field:=colnum, Criteria1:=">=0"
On Error Resume Next 'in case no visible rows to count
visRows = loop_obj.DataBodyRange.Columns(1).SpecialCells(xlCellTypeVisible).Count
On Error GoTo 0
If visRows > 0 Then
Set rngDest = Sheets("destination").Range("B2")
i = 0
For Each col In Array(1, 2, 3, 4, 5)
loop_obj.DataBodyRange.Columns(col).SpecialCells(xlCellTypeVisible).Copy
rngDest.Parent.Paste Destination:=rngDest.Offset(0, i)
i = i + 1
Next col
End If
loop_obj.AutoFilter.ShowAllData
End Sub
EDIT: a different array-based approach - this is faster, but again it's more complex, so there's a trade-off.
Sub Tester()
Dim wsCopy As Worksheet, loop_copy As Range
Dim loop_obj As ListObject, colnum As Long
Dim col, visRows As Long, rngDest As Range, i As Long, data
Set wsCopy = Sheets("Details")
Set loop_obj = wsCopy.ListObjects(1)
loop_obj.AutoFilter.ShowAllData
colnum = Application.Match("DateOrder", loop_obj.HeaderRowRange, 0)
If IsError(colnum) Then
MsgBox "Header not found!"
Exit Sub
End If
Application.ScreenUpdating = False
loop_obj.Range.AutoFilter Field:=colnum, Criteria1:=">=0"
data = arrayFromVisibleRows(loop_obj.DataBodyRange)
If Not IsEmpty(data) Then
With Sheets("Destination").Range("B2")
.CurrentRegion.ClearContents
.Resize(UBound(data, 1), UBound(data, 2)).Value = data
End With
End If
loop_obj.AutoFilter.ShowAllData
End Sub
'Return a 2D array using only visible row in `rng`
' Optionally include only column indexes in `cols` (passed as a 1D array)
Function arrayFromVisibleRows(rng As Range, Optional cols As Variant = Empty)
Dim rngVis As Range, data, dataOut
Dim rw As Long, col, e, c As Range, cOut As Long, rOut As Long, srcRow As Long
On Error Resume Next
Set rngVis = rng.Columns(1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngVis Is Nothing Then
data = rng.Value 'read all the range data to an array
If IsEmpty(cols) Then
'create an array with all column indexes if none were provided
cols = Application.Transpose(Evaluate("=ROW(1:" & rng.Columns.Count & ")"))
End If
'size the output array
ReDim dataOut(1 To rngVis.Cells.Count, 1 To (UBound(cols) - LBound(cols)) + 1)
rOut = 1
For Each c In rngVis.Cells
cOut = 1
srcRow = 1 + (c.Row - rng.Cells(1).Row)
For Each col In cols 'loop the required columns
dataOut(rOut, cOut) = data(srcRow, col)
cOut = cOut + 1
Next col
rOut = rOut + 1
Next c
arrayFromVisibleRows = dataOut
Else
arrayFromVisibleRows = Empty
End If
End Function
I think that this is close to what the OP wants. I didn't bother saving the file because its not relevant to my test and I added column headers.
Sub Main()
Dim tCopyTable As ListObject
Set tCopyTable = wsCopy.ListObjects(1)
Dim DateOrder As ListColumn
Dim Source As Range
With tCopyTable
If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
Set DateOrder = tCopyTable.ListColumns("DateOrder")
.Range.AutoFilter Field:=DateOrder.Index, Criteria1:=">=0"
Set Source = .Range.Offset(1)
End With
Dim CountOfVisibleDates As Long
CountOfVisibleDates = WorksheetFunction.Subtotal(103, Source.Columns(DateOrder.Index))
If CountOfVisibleDates > 0 Then
Dim wb As Workbook
Set wb = Workbooks.Add
With wb.Worksheets(1)
tCopyTable.HeaderRowRange.Resize(1, 5).Copy .Range("A1")
Source.Resize(, 5).Copy .Range("A2")
End With
End If
End Sub
Note: Looping through the values is almost always much faster than copying ranges.
Addendum
Sub Main2()
Dim tCopyTable As ListObject
Set tCopyTable = wsCopy.ListObjects(1)
Dim DateOrder As ListColumn
Dim Source As Range
With tCopyTable
If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
Set DateOrder = tCopyTable.ListColumns("DateOrder")
.Range.AutoFilter Field:=DateOrder.Index, Criteria1:=">=0"
Set Source = .Range.Offset(1)
End With
Dim CountOfVisibleDates As Long
CountOfVisibleDates = WorksheetFunction.Subtotal(103, Source.Columns(DateOrder.Index))
Dim OriginalColumnOrder As Variant
Dim NewColumnOrder As Variant
OriginalColumnOrder = Array(1, 2, 3, 4, 5)
NewColumnOrder = Array(3, 2, 1, 5, 4)
Dim c As Long
If CountOfVisibleDates > 0 Then
Dim wb As Workbook
Set wb = Workbooks.Add
With wb.Worksheets(1)
For c = 0 To UBound(NewColumnOrder)
tCopyTable.HeaderRowRange.Columns(OriginalColumnOrder(c)).Copy .Rows(1).Columns(NewColumnOrder(c))
Source.Resize(, 5).Columns(OriginalColumnOrder(c)).Copy .Rows(2).Columns(NewColumnOrder(c))
Next
End With
End If
End Sub
Result
I was in a rush. This is all that is needed to copy the headers and filtered data:
tCopyTable.ListColumns(OriginalColumnOrder(c)).Range.Copy .Rows(1).Columns(NewColumnOrder(c))
If you just want the data use:
tCopyTable.ListColumns(OriginalColumnOrder(c)).DataBodyRange.Copy .Rows(1).Columns(NewColumnOrder(c))
I am looking for a way to select an entire row but skip the first 3 columns of the same row without using 'range()' command. What command can i use?
You can use a combination of Cells and Resize:
Range.Cells Property
Range.Resize Property
Depending on how you ask the question (skip first column or first column is), you can use the combination as follows:
Option Explicit
Sub EntireSkipColumns()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rng As Range
Dim FR As Long: FR = 2
Dim LR As Long: LR = 10
Dim i As Long
Dim j As Long: j = 3 ' Skip first 3 columns
For i = FR To LR
Set rng = ws.Cells(i, j + 1).Resize(, ws.Columns.Count - j)
With rng
' To check if the range is correct.
Debug.Print .Address(False, False)
' Cycle Interior ColorIndex
'.Interior.ColorIndex = i
End With
Next i
End Sub
Sub EntireFirstColumn()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rng As Range
Dim FR As Long: FR = 2
Dim LR As Long: LR = 10
Dim i As Long
Dim j As Long: j = 4 ' Use 4 as the first column
For i = FR To LR
Set rng = ws.Cells(i, j).Resize(, ws.Columns.Count - j + 1)
With rng
' To check if the range is correct.
Debug.Print .Address(False, False)
' Cycle Interior ColorIndex
'.Interior.ColorIndex = i
End With
Next i
End Sub
EDIT:
Set rngTarget = rngTarget.Offset(1) is only used to move each result a row below.
Sub QualifyCellsToo()
Dim wsSource As Worksheet: Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Dim wsTarget As Worksheet: Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
Dim rngSource As Range
Dim rngTarget As Range
' This is wrong:
'Worksheets("sheets1").Range(Cells(3, 4), Cells(3, 9)).Copy _
Worksheets("sheets2").Range(Cells(3, 4), Cells(3, 9))
' You have to qualify 'Cells', too:
Worksheets("Sheet1").Range(Worksheets("Sheet1").Cells(3, 4), _
Worksheets("Sheet1").Cells(3, 9)).Copy _
Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(3, 4), _
Worksheets("Sheet2").Cells(3, 9))
' This is a long expression, so using variables is preferred.
Set rngSource = wsSource.Range(wsSource.Cells(3, 4), wsSource.Cells(3, 9))
Set rngTarget = wsTarget.Range(wsTarget.Cells(3, 4), wsTarget.Cells(3, 9))
Set rngTarget = rngTarget.Offset(1)
rngTarget.Resize(10).Clear
' Copy values or formulas and formats using same sized ranges.
rngSource.Copy rngTarget
Set rngTarget = rngTarget.Offset(1)
' Copy values or formulas and formats using only the first cell
' of Target Range.
rngSource.Copy rngTarget.Cells(1)
Set rngTarget = rngTarget.Offset(1)
' Copy values
rngTarget.Value = rngSource.Value
Set rngTarget = rngTarget.Offset(1)
' Copy values using target without '.Value'
rngTarget = rngSource.Value
Set rngTarget = rngTarget.Offset(1)
End Sub
I'm trying to compare sheet1 "A" column values to sheet2 "E:E" column values and copy/paste the whole line of every match to sheet3. Please help me to complete this task. I'm very new to VBA.
Thank you very much in advance!
Sub DelDups_TwoLists()
Dim iListCount As Integer
Dim iCtr As Integer
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
' Get count of records to search through (list that will be deleted).
iListCount = Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row
' Loop through the "master" list.
For Each x In Sheets("Sheet2").Range("E:E" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
' Loop through all records in the second list.
For iCtr = iListCount To 1 Step -1
' Do comparison of next record.
' To specify a different column, change 1 to the column number.
If x.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
' If match is true then delete row.
Sheets("Sheet1").Cells(iCtr, 1).EntireRow.Copy
Sheets("Sheet3").Select.Paste
End If
Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Sub DelDupsTwoLists()
Dim lastRowWs1 As Long, lastRowWs2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Set ws3 = Worksheets(3)
lastRowWs1 = LastRow(ws1.Name, 1)
lastRowWs2 = LastRow(ws2.Name, 5) 'E = 5
Dim myCell1 As Range, myCell2 As Range
Dim ws1Range As Range, ws2Range As Range
Set ws1Range = ws1.Range(ws1.Cells(1, "A"), ws1.Cells(lastRowWs1, 1))
Set ws2Range = ws2.Range(ws2.Cells(1, "E"), ws2.Cells(lastRowWs2, 1))
Dim rangeToDelete As Range
For Each myCell1 In ws1Range
For Each myCell2 In ws2Range
If myCell1.Value = myCell2.Value Then
Dim lastRowWs3: lastRowWs3 = LastRow(ws3.Name, 1) + 1
myCell2.EntireRow.Copy Destination:=ws3.Cells(lastRowWs3, 1)
If Not rangeToDelete Is Nothing Then
Set rangeToDelete = Union(rangeToDelete, myCell2.EntireRow)
Else
Set rangeToDelete = myCell2.EntireRow
End If
End If
Next
Next
If Not rangeToDelete Is Nothing Then
Debug.Print "Deleting rangeToDelete - "; rangeToDelete.Address
rangeToDelete.Delete
End If
Debug.Print "Done!"
End Sub
Public Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long
Dim ws As Worksheet
Set ws = Worksheets(wsName)
LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row
End Function
Pretty much I rewrote the whole code from scratch. It pretty much uses the initial n2 complexity, but is rather faster than that, because the deletion of the rows in WorkSheet(2) is done in a single last step rangeToDelete.Delete, which saves a lot of time.
Pretty much, the code defines 2 ranges with which is works - ws1Range and ws2Range, using the LastRow function. Once it defines them, it starts looping through them and comparing them. Hence the n2 complexity. In case of equal values, the row is copied and the cell is added to the rangeToDelete.
Note - it will probably not work as "out of the box solution", but try to debug further with F8 and see what happens.
Additionally:
Using Integer is not a great idea in VBA.
"_" in the Sub name is used for Events in VBA, thus it is not a great idea to use it. (although it works)
How to avoid using Select in Excel VBA
Give this a try (see comments in code for more details):
Sub DelDups_TwoLists()
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
With ActiveWorkbook
Dim wsSrc As Worksheet: Set wsSrc = .Sheets("Sheet1") 'declare and set the source worksheet
Dim wsDst As Worksheet: Set wsDst = .Sheets("Sheet3") 'declare and set the destination worksheet
Dim R1 As Long, R2 As Long, C As Long, lRow As Long, lCol As Long 'declare variables to use
With wsSrc
lCol = .Cells(1, Columns.Count).End(xlToLeft).Column 'get the last column value in the source sheet, at row 1, will reuse this laster
Dim arrData_1 As Variant: arrData_1 = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1)) 'declare and allocate the source data to an array
End With
With .Sheets("Sheet2")
Dim arrData_2 As Variant: arrData_2 = .Range("E1:E" & .Cells(Rows.Count, 1).End(xlUp).Row) 'declare and allocate the compare data to an array
End With
End With
With wsDst
For R1 = LBound(arrData_1) To UBound(arrData_1) 'for each row in the source data
For R2 = LBound(arrData_2) To UBound(arrData_2) 'for each row in the compare data
If arrData_1(R1, 2) = arrData_2(R2, 1) Then 'if there is a match
lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 'get the last row in the destination sheet
.Range(.Cells(lRow, 1), .Cells(lRow, lCol)).Value = _
wsSrc.Range(wsSrc.Cells(R1, 1), wsSrc.Cells(R1, lCol)).Value 'allocate the matching values
Exit For 'exit early here if there is a match, go to next row to check
End If
Next R2
Next R1
End With
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
How can I concatenate unique cell values in every row to adapt in the code below. Removing duplicate values in a cell. Result after macro is the second image.
Sub Concatenar()
Dim myRange As Range
Dim c As Long
Dim r As Long
Dim txt As String
Set myRange = Application.InputBox("Selecione a primeira e a última célula:", Type:=8)
For r = 1 To myRange.Rows.Count
For c = 1 To myRange.Columns.Count
If myRange(r, c).Text <> "" Then
txt = txt & myRange(r, c).Text & vbLf
End If
Next
If Right(txt, 1) = vbLf Then
txt = Left(txt, Len(txt) - 1)
End If
myRange(r, 1) = txt
txt = ""
Next
Range(myRange(1, 2), myRange(1, myRange.Columns.Count)).EntireColumn.Delete
End Sub
This does what you want, I believe. It pastes/tranposes the values to a temporary workbook, uses RemoveDuplicates to trim them down, and Join to munge them all together. It then pastes the munged values back into column A of the original workbook and deletes the other columns.
Because of the destructive nature of this code, you must test it on a copy of your data:
Sub CrazyPaste()
Dim wsSource As Excel.Worksheet
Dim rngToConcat As Excel.Range
Dim wbTemp As Excel.Workbook
Dim wsPasted As Excel.Worksheet
Dim rngPasted As Excel.Range
Dim i As Long
Dim LastRow As Long
Dim Results() As String
Set wsSource = ActiveSheet
Set rngToConcat = wsSource.UsedRange
Set wbTemp = Workbooks.Add
Set wsPasted = wbTemp.Worksheets(1)
wsSource.UsedRange.Copy
wsPasted.Range("A1").PasteSpecial Transpose:=True
Set rngPasted = wsPasted.UsedRange
ReDim Results(1 To rngPasted.Columns.Count)
For i = 1 To rngPasted.Columns.Count
If WorksheetFunction.CountA(rngPasted.Columns(i)) = 0 Then
Results(i) = ""
Else
rngPasted.Columns(i).RemoveDuplicates Columns:=1, Header:=xlNo
LastRow = Cells(wsPasted.Rows.Count, i).End(xlUp).Row
Results(i) = Replace(Join(Application.Transpose(rngPasted.Columns(i).Resize(LastRow, 1)), vbCrLf), _
vbCrLf & vbCrLf, vbCrLf)
End If
Next i
With wsSource
.Range("A1").Resize(i - 1, 1) = Application.Transpose(Results)
.Range(.Cells(1, 2), .Cells(1, .Columns.Count)).EntireColumn.Delete
wbTemp.Close False
End With
End Sub
In my limited testing, the only situation where this might yield unwanted results is when a cell in the first column is blank, but there's other data in that row. The resulting cell would then start with a blank.