I'm finishing a script that verifies if a cell in Column A of Sheet1 ("INCIDENTS") is duplicated at Column A of Sheet2 ("INCDB") and if the cell is duplicate it deletes the whole row in Sheet1.
The problem is that after the first loop (and deleting the row) it gives me the 424 error and highlights If iSrc.Cells.Value = iDst.Cells.Value Then
Any ideas on the cause? Here's the code:
Sub CTDeleteDuplicatePaste()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim iSrc As Variant
Dim iDst As Variant
Dim rng As Range
Set ws1 = Sheets("INCIDENTS")
Set ws2 = Sheets("INCDB")
For Each iSrc In ws1.Range("A5:A9999" & LastRow)
For Each iDst In ws2.Range("A5:A9999")
If iSrc.Cells.Value = iDst.Cells.Value Then
If rng Is Nothing Then
Set rng = iSrc.EntireRow
Else
Set rng = Union(rng, iSrc.EntireRow)
End If
rng.EntireRow.Delete
End If
Next iDst
Next iSrc
End Sub
I'd do it without objects iSrc and iDst. And from reverse order - this code worked for me:
Sub CTDeleteDuplicatePaste()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim j As Long
Set ws1 = Sheets("INCIDENTS")
Set ws2 = Sheets("INCDB")
For i = 9 To 5 Step -1 'change 9 to 9999 for your real data
For j = 9 To 5 Step -1 'change 9 to 9999 for your real data
If Len(ws1.Cells(i, 1).Value) > 0 Then
If ws1.Cells(i, 1).Value = ws2.Cells(j, 1).Value Then
ws1.Cells(i, 1).EntireRow.Delete
GoTo nextIteration
End If
End If
Next
nextIteration:
Next
End Sub
Regarding the performance issue of .EntireRow.Delete, this is the additional reading:
Tests on processing 1 million rows
Solution employing Sorting
Related
my goal is to copy cells in a dynamic range from Column B to S to another sheet if they are non zero. Additionally, would like to move the cells up to the top of the next sheet (Without having to clear blank rows each time). Have the code working for 1 column (when Col was replaced with "B", "C", etc.) but when I tried to make it a for loop of multiple it doesnt work.
Any help would be appreciated!
Sub MoveFormulaDataLooped()
Dim ws1 As Worksheet: Set ws1 = Worksheets("Fancy Wall")
Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet1")
Dim VeryLastRow As Integer: VeryLastRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
Dim i As Integer
Dim Col As Integer
For i = 2 To VeryLastRow
For Col = 2 To 19
If ws1.Range(Col & i) > 0 Then
ws2.Range(Col & i) = ws1.Range(Col & i)
Next
Next
End Sub
A few notes:
You are looking for the property .Cells instead of .Range, as it uses row and column index to access your range.
You are missing an End If in you most inner conditional
You need to capture the next row for your ws2 so that you don't have blanks between them
I included a function that helps you find the next available row, and made the fixes from my notes above.
' Finds the next empty row on a worksheet.
Public Function NextAvailibleRow(ByRef ws As Worksheet) As Range
On Error GoTo catch
Set NextAvailibleRow = ws.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Offset(1).EntireRow
Exit Function
' If there is an error, that means the worksheet is empty.
' Return the first row
catch:
Set NextAvailibleRow = ws.Rows(1)
End Function
Sub MoveFormulaDataLooped()
Dim ws1 As Worksheet: Set ws1 = Worksheets("Fancy Wall")
Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet1")
Dim VeryLastRow As Integer
VeryLastRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
Dim i As Integer
For i = 2 To VeryLastRow
' Need to capture the next row for Sheet1
Dim nextSheet1Row As Long
nextSheet1Row = NextAvailibleRow(ws2).Row
Dim Col As Integer
For Col = 2 To 19
If ws1.Cells(i, Col) > 0 Then
' Use `.Cells`
ws2.Cells(nextSheet1Row, Col) = ws1.Cells(i, Col)
End If ' Was missing
Next
Next
End Sub
I have been trying to create a function which checks that if Col"B" <> Empty then copy the third cell which is under the same row.
I have this Data:
Where from i want to copy the Col"D" highlighted cells and paste them into same row where Col"B" <> empty.
Here is the final result. Your help will be appreciated in this regards.
Option Explicit
Sub CopyPasting()
Dim ws As Worksheet
Dim r As Long
Dim LastRow As Long
Dim n As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
LastRow = .Range("D" & .Rows.Count).End(xlUp).Row
For r = LastRow To 2 Step -2
If .Cells(r, "B") <> "" Then
.Rows(r + "D").Copy
.Rows(r + "D").PasteSpecial
n = n + 1
End If
Next
End With
End Sub
Please, try the next code:
Sub testRetOffset3()
Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, c As Range
Set sh = ActiveSheet 'use here the sheet you need
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last sheet row
On Error Resume Next 'if not empty cells in column, it will not return the range and raise an error
Set rngV = sh.Range("B2:B" & lastR).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rngV Is Nothing Then Exit Sub 'stop the code if run on a wrong sheet, without empty cells in column B:B
For Each c In rngV.cells 'iterate between the discontinuous range cells
If rngFin Is Nothing Then 'if the final range is not set (first time)
Set rngFin = c.Offset(3, 2) 'set the range = the Offset necessary cell
Else
Set rngFin = Union(rngFin, c.Offset(3, 2)) 'make a Union between existing range and the Offset necessary cell
End If
Next
If Not rngFin Is Nothing Then 'copy both ranges in consecutive columns
rngV.Copy sh.Range("F2")
rngFin.Copy sh.Range("G2")
End If
End Sub
It will return in columns F:G, starting from the second row. It is easy to modify the range where to return...
You can even clear the existing processed columns and return in B:C, or in another sheet.
Edited:
In order to solve the last request, please use the next code:
Sub testRetOffsetMoreRows()
Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, A As Range
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
On Error Resume Next
Set rngV = sh.Range("A2:D" & lastR).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rngV Is Nothing Then Exit Sub
For Each A In rngV.Areas 'iterate between the range areas
If rngFin Is Nothing Then
Set rngFin = A.cells(1,2).Offset(3, 3) 'use the second cell of the area
Else
Set rngFin = Union(rngFin, A.cells(1,2).Offset(3, 3))
End If
Next
If Not rngFin Is Nothing Then
rngV.Copy sh.Range("H2")
rngFin.Copy sh.Range("L2")
End If
End Sub
But take care to have continuous ranges when have a value in column B:B. Otherwise, the code may fail... The areas property will return differently.
I wasn't sure where you wanted the output, this will put it into a sheet called "Sheet2". (You'll have to make that before running the code it won't create it for you.)
Dim i As Long
Dim j As Long
Dim lr As Long
Dim srcWS As Worksheet
Dim destWS As Worksheet
Set srcWS = ThisWorkbook.Sheets("Sheet1")
Set destWS = ThisWorkbook.Sheets("Sheet2")
With srcWS
lr = .Cells(.Rows.Count, 4).End(xlUp).Row
j = 2
For i = 2 To lr
If .Cells(i, 2).Value <> "" Then
destWS.Cells(j, 1).Value = .Cells(i, 2).Value
destWS.Cells(j, 2).Value = .Cells(i, 4).Offset(2, 0).Value
j = j + 1
End If
Next i
End With
If you need the colors copied over as well then use this:
.Cells(i, 4).Offset(2, 0).Copy
destWS.Cells(j, 2).PasteSpecial xlPasteAll
instead of:
destWS.Cells(j, 2).Value = .Cells(i, 4).Offset(2, 0).Value
I have data in a table, where I compare two columns J and T. The values which J and T can take include A2B, APL, BGF, CMA, among others (see code).
If these values are equal, copy row i into the sheet which has the name of the cells just checked.
If these values are not equal, copy row i into the sheets which have the name of the cells just checked.
Example: Compare J2 and T2,
Suppose J2=T2=BGF then copy row 2 and paste into sheet("BGF")
Next, compare J3 and T3
Suppose J3=BGF and T3=CMA, copy row 3 and paste into sheet(BGF) and sheet(CMA)
Next, compare J4 and T4
Suppose J4=Nothing and T4=CMA, copy row 4 and paste into sheet CMA
the only other combination is where Ji has a value and Ti is empty.
Problem: When running this code, If J3=BGF and T3= nothing (its empty), then the line is not copied to any sheet.
Here's the code
Sub Sortdata()
'step 1 clear all data
Sheets("A2B").Cells.ClearContents
Sheets("APL").Cells.ClearContents
Sheets("BGF").Cells.ClearContents
Sheets("CMA").Cells.ClearContents
Sheets("K Line").Cells.ClearContents
Sheets("MacAndrews").Cells.ClearContents
Sheets("Maersk").Cells.ClearContents
Sheets("OOCL").Cells.ClearContents
Sheets("OPDR").Cells.ClearContents
Sheets("Samskip").Cells.ClearContents
Sheets("Unifeeder").Cells.ClearContents
Dim i As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim LastRow As Long
With Worksheets("All Data")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
If IsEmpty(.Range("J" & i)) Then
Set ws1 = Nothing
Else
Set ws1 = Worksheets(.Range("J" & i).Value)
End If
If IsEmpty(.Range("T" & i)) Then
Set ws2 = Nothing
Else
Set ws2 = Worksheets(.Range("T" & i).Value)
End If
If ws1 Is Nothing Then
If Not ws2 Is Nothing Then
CopyToWs ws2, .Rows(i)
End If
ElseIf ws2 Is Nothing Then
If Not ws1 Is Nothing Then
CopyToWs ws1, .Rows(i)
End If
Else
CopyToWs ws1, Rows(i)
If ws1.Name <> ws2.Name Then
CopyToWs ws2, .Rows(i)
End If
End If
Next
End With
End Sub
Sub CopyToWs(ws As Worksheet, rng As Range)
rng.Copy
ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Please try this code. It takes a slightly different approach to what you tried but it gets the job done, I think.
Option Explicit
Sub Sortdata()
' Variatus #STO 20 Jan 2020
Const WsNames As String = "A2B,APL,BGF,CMA,K Line,MacAndrews," & _
"Maersk,OOCL,OPDR,Samskip,Unifeeder"
Dim WsS As Worksheet ' Source
Dim Ws As Worksheet
Dim Rng As Range
Dim Rt As Long ' target row
Dim LastRow As Long
Dim J As Long, T As Long
Dim Tmp As Variant, PrevTmp As Variant
Dim R As Long, C As Long
'step 1 clear all data
Tmp = Split(WsNames, ",")
For R = LBound(Tmp) To UBound(Tmp)
On Error Resume Next
Worksheets(Tmp(R)).Cells.ClearContents
Next R
Application.ScreenUpdating = False
Set WsS = Worksheets("All Data")
With WsS
J = .Columns("J").Column
T = .Columns("T").Column
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For R = 2 To LastRow
PrevTmp = ""
For C = J To T Step T - J
Tmp = .Cells(R, C).Value
If Len(Tmp) And Tmp <> PrevTmp Then
On Error Resume Next
Set Ws = Worksheets(Tmp)
If Err = 0 Then
Set Rng = .Range(.Cells(R, 1), .Cells(R, .Columns.Count).End(xlToLeft))
With Ws
Rt = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 2)
Rng.Copy Destination:=Ws.Cells(Rt, 1)
End With
End If
End If
PrevTmp = Tmp
Next C
If R Mod 25 = 0 Then Application.StatusBar = "Currently processing row " & R
Next R
End With
With Application
.ScreenUpdating = True
.StatusBar = "Done"
End With
End Sub
I think you will be able to find your way through it and make any required modifications. Let me know if you require any assistance.
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
I am trying to create a Macro that will look through all the worksheets in a workbook and find the column named "ID". There will be an "ID" column in most of the worksheets, but the header may not necessarily be in row 1. Once the column has been found I would like to copy all the data in that column to a new worksheet. When copying the data over to a new worksheet I would like the data to be copied all in column A in the new worksheet- so would like the data to be copied into the next blank cell. So far this is what I have got
Sub Test()
Dim ws As Worksheet
Dim sString As String
Dim sCell As Variant
Dim cfind As Range
Dim j As Integer
For Each ws In Worksheets
If ws.Name = "Archive" Then GoTo nextws
ws.Activate
j = ActiveSheet.Index
'MsgBox j
On Error Resume Next
Set cfind = Cells.Find(what:="ID", lookat:=xlWhole)
If Not cfind Is Nothing Then
cfind.EntireColumn.Copy
Worksheets("Archive").Range("A1").Offset(0, j - 1).PasteSpecial
End If
nextws:
Next ws
End Sub
I cant seem to get the last bit right that pastes the data. At the moment it just pastes it in the next available column.
So, you want all in Column A, right?
Change to
With Worksheets("Archive")
If .Range("A1") = "" Then
.Range("A1").PasteSpecial
Else
.Range("A1").Offset(.UsedRange.Rows.Count).PasteSpecial
End If
End With
from
Worksheets("Archive").Range("A1").Offset(0, j - 1).PasteSpecial
This will line up the ID headers on row 1:
Sub Test()
Const SHT_ARCHIVE As String = "Archive"
Dim ws As Worksheet
Dim cfind As Range, rngList As Range
Dim j As Integer
j = 0
For Each ws In Worksheets
If ws.Name <> SHT_ARCHIVE Then
j = j + 1
Set cfind = ws.UsedRange.Find(what:="ID", lookat:=xlWhole, LookIn:=xlValues)
If Not cfind Is Nothing Then
Set rngList = Range(cfind, ws.Cells(Rows.Count, cfind.Column).End(xlUp))
Worksheets(SHT_ARCHIVE).Cells(1, j).Resize(rngList.Rows.Count, 1).Value = rngList.Value
End If
End If
Next ws
End Sub