I'm trying to search sheet_A for values in sheet_B / column A (starting from A2) and if they exist in sheet_A (column C, starting in C2) they get removed from sheet_A.
Sub Remover_Duplicados()
'Backup to another sheet
Const strSheetName As String = "BKP_sheet"
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0
If wsTest Is Nothing Then
Worksheets.Add.Name = strSheetName
End If
Sheets("sheet_A").Range("A1:BK3500").Copy Destination:=Sheets(strSheetName).Range("A1")
'Search and destroy
Dim searchableRange As Range
Dim toRemoveRange As Range
Dim lLoop As Long
Set searchableRange = Worksheets("sheet_B").Range("A2", "A3500")
Set toRemoveRange = Worksheets("sheet_A").Range("C2", "C3500")
For lLoop = searchableRange.Rows.Count To 2 Step -1
If WorksheetFunction.CountIf(searchableRange, toRemoveRange(lLoop).Value) > 0 Then
Worksheets("sheet_A").Rows(lLoop).Delete shift:=xlUp
End If
Next lLoop
End Sub
Sheet A, B and the result:
Some don't get removed.
I've gone through your code and amended it slightly to be more dynamic with the ranges, I've also used an Array to populate the values to be removed and then looped though that array to decide whether the row should be deleted or not:
Sub Remover_Duplicados()
'Backup to another sheet
Const strSheetName As String = "BKP_sheet"
Dim wsA As Worksheet: Set wsA = ThisWorkbook.Worksheets("Sheet_A")
Dim wsB As Worksheet: Set wsB = ThisWorkbook.Worksheets("Sheet_B")
Dim arrToRemove()
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ThisWorkbook.Worksheets(strSheetName)
On Error GoTo 0
If wsTest Is Nothing Then
Worksheets.Add.Name = strSheetName
End If
LastRowA = wsA.Cells(wsA.Rows.Count, "A").End(xlUp).Row
wsA.Range("A1:BK" & LastRowA).Copy Destination:=Sheets(strSheetName).Range("A1")
LastRowB = wsB.Cells(wsB.Rows.Count, "A").End(xlUp).Row
arrToRemove = wsB.Range("A2:A" & LastRowB).Value
For iRow = LastRowA To 2 Step -1
For iArray = LBound(arrToRemove) To UBound(arrToRemove)
If wsA.Cells(iRow, "C").Value = arrToRemove(iArray, 1) Then
wsA.Rows(iRow).EntireRow.Delete shift:=xlUp
End If
Next iArray
Next iRow
End Sub
Related
I have a list of 10 specific customers that I need excel to search and filter their numbers among hundred of customers in column D and when it finds them, based on their company code in column A, move the filtered range to a new sheet with a header (i want to move each customer with a header, not all of them under the same header) and name the news sheet same as the company code in column A
My Columns go from A to AC
What it looks like:
I wonder how can i pull this successfully using VBA
Adding Header to each customer:
Please, test the next code. It, basically, uses a dictionary to keep unique Company Codes, an array for the ten customers, a column array to faster load the dictionary:
Sub CopyFilteredCustomersByCompanyNames()
Dim wb As Workbook, ws As Worksheet, lastR As Long, wsComp As Worksheet, dictC As Object
Dim rngFilt As Range, arrCust() As Variant, arrFilt, i As Long
arrCust = Array("108169651", "108169651", "108169430", "108169430", "108168704", "108169596") 'place here the 10 specific customers name
Set wb = ActiveWorkbook 'use here the workbook you need
Set ws = ActiveSheet 'use here the necessary sheet (the one to be processed)
If ws.FilterMode Then ws.ShowAllData
Set rngFilt = ws.Range("A1").CurrentRegion: ' Debug.Print rngFilt.Address: Stop
arrFilt = rngFilt.Value2 'place the range in an array for faster iteration
'extract the uneque Company Names:
Set dictC = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrFilt)
If arrFilt(i, 1) <> "" Then
dictC(arrFilt(i, 1)) = dictC(arrFilt(i, 1)) + 1
End If
Next i
Application.ScreenUpdating = False 'optimization to make code faster
Dim keyC As Variant, rngF As Range, rngF1 As Range
For Each keyC In dictC.Keys 'iterate between dictionary keys (A:A company names)
rngFilt.AutoFilter 1, keyC 'first filter by dict key
rngFilt.AutoFilter 4, arrCust, xlFilterValues 'second by array of customers numbers
Set wsComp = Nothing
'insert the necessary sheets, name them (if not existing), clear if existing and copy the filtered range
Application.EnableEvents = False: Application.Calculation = xlCalculationManual
Application.AutomationSecurity = msoAutomationSecurityForceDisable
On Error Resume Next
Set wsComp = wb.Worksheets(keyC)
On Error GoTo 0
If Not wsComp Is Nothing Then
wsComp.Cells.ClearContents
Else
Set wsComp = wb.Worksheets.Add(After:=ws)
wsComp.Name = keyC
End If
rngFilt.Rows(1).Copy ' copy the headers columns width
wsComp.Range("A1").Resize(, rngFilt.Rows(1).Columns.Count).PasteSpecial xlPasteColumnWidths
On Error Resume Next
Set rngF1 = Nothing
Set rngF1 = rngFilt.Resize(rngFilt.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible):
Set rngF = rngFilt.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngF1 Is Nothing Then
rngF.Copy wsComp.Range("A1")
Else
Application.DisplayAlerts = False
wb.Worksheets(keyC).Delete
Application.DisplayAlerts = True
End If
ws.ShowAllData
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.EnableEvents = True: Application.Calculation = xlCalculationAutomatic
Next keyC
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
Please, send some feedback after testing it.
If something not clear enough, do not hesitate to ask for clarifications.
First create a tab by name CCList & enter all 10 company codes
for which you have to generate the report.
Secondly Paste the data in the Data tab.
Run this code.
In a new module
Sub GenerateReport()
Dim WsData As Worksheet, WsCCList As Worksheet
Dim FRow As Long, LRow As Long, FCol As Long, LCol As Long
Dim CCFrow As Long, CCLRow As Long, CCCol As Long, CCCounter As Long
Dim ValidationRng As Range, DataRng As Range, SrchString As String
Set WsData = Worksheets("Data")
Set WsCCList = Worksheets("CCList")
WsData.Activate
FRow = 1
FCol = 1
LRow = WsData.Cells(WsData.Rows.Count, FCol).End(xlUp).Row
LCol = WsData.Cells(FRow, WsData.Columns.Count).End(xlToLeft).Column
Set DataRng = WsData.Range(Cells(FRow, FCol), Cells(LRow, LCol))
WsCCList.Activate
CCFrow = 2
CCCol = 1
CCLRow = WsCCList.Cells(WsCCList.Rows.Count, CCCol).End(xlUp).Row
For CCCounter = CCFrow To CCLRow
SrchString = ""
SrchString = WsCCList.Cells(CCCounter, CCCol)
If SrchString = "" Then Exit Sub
If WsData.AutoFilterMode = True Then WsData.AutoFilterMode = False
DataRng.AutoFilter Field:=1, Criteria1:=SrchString, Operator:=xlFilterValues
On Error Resume Next
Set ValidationRng = Nothing
Set ValidationRng = WsData.AutoFilter.Range.Offset(1, 0).Resize(DataRng.Rows.Count - 1, DataRng.Columns.Count).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If ValidationRng Is Nothing Then
'do nothing
Else
Worksheets.Add After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Name = SrchString
DataRng.SpecialCells(xlCellTypeVisible).Copy
ActiveSheet.Range("a1").PasteSpecial
Application.CutCopyMode = False
End If
If WsData.AutoFilterMode = True Then WsData.AutoFilterMode = False
Next CCCounter
WsCCList.Select
MsgBox "Task Completed"
End Sub
Using the below code to delete the repeated headers from combined into one excel but getting error.
Application.Goto DestSh.Cells(1)
' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Combined Sheet" Then
xWs.Delete
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Dim lstRow As Integer, ws As Worksheet
Set ws = ThisWorkbook.Sheets("Combined Sheet")
With ws
lstRow = .Cells(rows.Count, "B").End(xlUp).Row ' Or "C" or "A" depends
.Range("A1:E" & lstRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete ERROR GETTING HERE
End With
enter image description here
Please add "on error resume next" before using SpecialCells method and after using use "on error GoTo 0"
.SpecialCells(xlCellTypeBlanks)
This expression gives you every blank cell in a Range. Rows that you are going to delete includes non-blank cells also, so vba will not delete them.
You can try a RemoveDuplicates method like:
.Range("A1:E" & lstRow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header :=xlNo
It can be not safe to use the method, but for your task it's may be Ok.
This sub is a safe variant to delete your headers. you can call the sub by the Call statement, and don't forget to set your header address.
Call removeHeaders()
Sub removeHeaders()
Dim hdrRangeAdr As String
Dim l, frstRow, lstRow, offsetRow As Long
Dim counter, row1, row2 As Integer
Dim item As Variant
Dim hdrRng, tRng As Range
Dim ws As Worksheet
' setting of the first header address
hdrRangeAdr = "A1:O1"
Set ws = ThisWorkbook.Sheets("Combined Sheet")
' setting of the header range
Set hdrRng = ws.Range(hdrRangeAdr)
hdrRowsQty = hdrRng.Rows.Count
frstRow = hdrRng.Row
lstRow = hdrRng.Parent.UsedRange.Rows.Count + frstRow
'checking row by row
For l = 1 To lstRow - frstRow
offsetRow = l + hdrRowsQty - 1
counter = 0
' compare row/rows value with the header
For Each item In hdrRng.Cells
If item = item.Offset(offsetRow, 0) Then
counter = counter + 1
End If
Next
' if they are equial then delete rows
If counter = hdrRng.Count Then
row1 = frstRow + offsetRow
row2 = row1 + hdrRowsQty - 1
ws.Rows(row1 & ":" & row2).Delete Shift:=xlUp
'reseting values as rows qty reduced
l = 1
lstRow = hdrRng.Parent.UsedRange.Rows.Count + frstRow
End If
Next
Set ws = Nothing
Set hdrRng = Nothing
End Sub
Good luck
I have a workbook with several worksheets. The main worksheet is the Data worksheet.
The search criteria are in the Data worksheet B2,C2 and D2.The other sheets are cross tabs in which the prices are located. The prices I am looking for should be transferred in sheet Data column G2. I stuck with following code.
Dim wks As Worksheet
Dim wksData As Worksheet: Set wksData = Sheets("Data")
Dim lngrow As Long
Dim lngrow2 As Long
Dim lngSpalte As Long
For lngrow = 2 To wksData.Cells(Rows.Count, 2).End(xlUp).Row
Select Case wksData.Cells(lngrow, 2).Value
Case "Standard"
Set wks = Sheets("Standard")
Case "Express Plus"
Set wks = Sheets("Express Plus")
Case "Express Saver"
Set wks = Sheets("Express Saver")
End Select
For lngrow2 = 2 To wks.Cells(Rows.Count, 2).End(xlUp).Row
If Trim(wks.Cells(lngrow2, 2).Value) = Trim(wksData.Cells(lngrow, 3).Value) Then
For lngSpalte = 2 To 10
If Trim(wks.Cells(lngSpalte, 3).Value) = Trim(wksData.Cells(lngrow, 4)) Then
wksData.Cells(lngrow, 7).Value = wks.Cells(lngrow2, lngSpalte).Value
Exit For
End If
Next
End If
Next
Next
Is anyone able to help? Thank you!
EDIT - based on your sample workbook...
Sub Tester()
Dim wksData As Worksheet, wks As Worksheet
Dim lngrow As Long
Dim delType, delZone, delWeight, mCol, rv
Dim rngWts As Range, arrWts, rngZones As Range, i As Long, w As Double
Set wksData = Sheets("Data")
For lngrow = 2 To wksData.Cells(Rows.Count, 2).End(xlUp).Row
delType = Trim(wksData.Cells(lngrow, "B").Value) 'use some descriptive variables!
delZone = wksData.Cells(lngrow, "C").Value
delWeight = CDbl(Trim(wksData.Cells(lngrow, "D").Value))
rv = "" 'clear result value
Select Case delType
Case "Standard", "Express Plus", "Express Saver"
Set wks = Sheets(delType) 'simpler...
Set rngWts = wks.Range("A3:A" & wks.Cells(Rows.Count, "A").End(xlUp).Row)
arrWts = rngWts.Value
'loop over the weights data
For i = 1 To UBound(arrWts, 1) - 1
If delWeight >= arrWts(i, 1) And delWeight < arrWts(i + 1, 1) Then
Set rngZones = wks.Range("B2", wks.Cells(2, Columns.Count).End(xlToLeft)) 'zones range
mCol = Application.Match(delZone, rngZones, 0) 'find the matching Zone
If Not IsError(mCol) Then 'got zone match?
rv = rngWts.Cells(i).Offset(0, mCol).Value
Else
rv = "Zone?"
End If
Exit For 'stop checking weights column
End If
Next i
If Len(rv) = 0 Then rv = "No weight match"
Case Else
rv = "Delivery type?"
End Select
wksData.Cells(lngrow, "G").Value = rv 'populate the result
Next
End Sub
I am building out a workbook where every sheet is for a different stage of a software installation. I am trying to aggregate the steps that fail by copying my fail rows into a summary sheet. I finally got them to pull, but they are pulling into the new sheet on the same row # as they are located in the original sheet.
Here is what I am using now:
Option Explicit
Sub Test()
Dim Cell As Range
With Sheets(7)
' loop column H untill last cell with value (not entire column)
For Each Cell In .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
If Cell.Value = "Fail" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next Cell
End With
End Sub
I need to:
Pull row that has cell containing "Fail"
Copy row into master starting at Row 4 and consecutively down without overwriting
Run across all sheets at once-
*(they are named per step of install - do i need to rename to "sheet1, sheet2, etc"????)
When macro is run clear previous results (to avoid duplicity)
Another user offered me an autofilter macro but it is failing on a 1004 at this line ".AutoFilter 4, "Fail""
Sub Filterfail()
Dim ws As Worksheet, sh As Worksheet
Set sh = Sheets("Master")
Application.ScreenUpdating = False
'sh.UsedRange.Offset(1).Clear 'If required, this line will clear the Master sheet with each transfer of data.
For Each ws In Worksheets
If ws.Name <> "Master" Then
With ws.[A1].CurrentRegion
.AutoFilter 4, "Fail"
.Offset(1).EntireRow.Copy sh.Range("A" & Rows.Count).End(3)(2)
.AutoFilter
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub
Try this:
The text “Completed” in this xRStr = "Completed" script indicates the specific condition that you want to copy rows based on;
C:C in this Set xRg = xWs.Range("C:C") script indicates the specific column where the condition locates.
Public Sub CopyRows()
Dim xWs As Worksheet
Dim xCWs As Worksheet
Dim xRg As Range
Dim xStrName As String
Dim xRStr As String
Dim xRRg As Range
Dim xC As Integer
On Error Resume Next
Application.DisplayAlerts = False
xStr = "New Sheet"
xRStr = "Completed"
Set xCWs = ActiveWorkbook.Worksheets.Item(xStr)
If Not xCWs Is Nothing Then
xCWs.Delete
End If
Set xCWs = ActiveWorkbook.Worksheets.Add
xCWs.Name = xStr
xC = 1
For Each xWs In ActiveWorkbook.Worksheets
If xWs.Name <> xStr Then
Set xRg = xWs.Range("C:C")
Set xRg = Intersect(xRg, xWs.UsedRange)
For Each xRRg In xRg
If xRRg.Value = xRStr Then
xRRg.EntireRow.Copy
xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
xC = xC + 1
End If
Next xRRg
End If
Next xWs
Application.DisplayAlerts = True
End Sub
Here's another way - You'll have to assign your own Sheets - I used 1 & 2 not 2 & 7
Sub Test()
Dim xRow As Range, xCel As Range, dPtr As Long
Dim sSht As Worksheet, dSht As Worksheet
' Assign Source & Destination Sheets - Change to suit yourself
Set sSht = Sheets(2)
Set dSht = Sheets(1)
' Done
dPtr = Sheets(1).Rows.Count
dPtr = Sheets(1).Range("D" & dPtr).End(xlUp).Row
For Each xRow In sSht.UsedRange.Rows
Set xCel = xRow.Cells(1, 1) ' xCel is First Column in Used Range (May not be D)
Set xCel = xCel.Offset(0, 4 - xCel.Column) ' Ensures xCel is in Column D
If xCel.Value = "Fail" Then
dPtr = dPtr + 1
sSht.Rows(xCel.Row).Copy Destination:=dSht.Rows(dPtr)
End If
Next xRow
End Sub
I think one of the problems in your own code relates to this line
.Rows(Cell.Row).Copy Destination:=Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
The section Rows.Count, "A" should be referring to the destination sheet(2) but isn't because of the line
With Sheets(7)
further up
I am trying to create a program that will copy a row based on the value in column P into another sheet in the same workbook. Column P can be:
Design
Production
Process
Safety
Quality
Purchasing
I want the program to look at the Column P and if it says "design" then copy and paste that row into the sheet labeled "Design" and so on and so forth.
Can anyone help me?
Line
Set tosheet = Worksheets("" & fromsheet.Cells(r, "P"))
works fine initially then throw off an error of 'Run Time Error 9 after the first iteration.
Sub lars_ake_copy_rows_to_sheets()
Dim firstrow, lastrow, r, torow As Integer
Dim fromsheet, tosheet As Worksheet
firstrow = 2
Set fromsheet = ActiveSheet
lastrow = ActiveSheet.Cells(Rows.Count, "P").End(xlUp).Row
For r = firstrow To lastrow
If fromsheet.Cells(r, "P") <> "" Then 'skip rows where column P is empty
On Error GoTo make_new_sheet
Set tosheet = Worksheets("" & fromsheet.Cells(r, "P"))
On Error GoTo 0
GoTo copy_row
make_new_sheet:
Set tosheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
tosheet.Name = fromsheet.Cells(r, "P")
copy_row:
torow = tosheet.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
fromsheet.Cells(r, 1).EntireRow.Copy
tosheet.Cells(torow, 1).PasteSpecial Paste:=xlPasteValues
End If
Next r
Application.CutCopyMode = False
fromsheet.Activate
End Sub
I want this code to create new worksheet if already not created.
But this code create new sheet for only 1st record of column p which is design, if this sheet not created before but for the next record which is Production if the worksheet by the name of Production is not created before then this code throw an error of Run Time 9. Anyone who can fix this for me.
As I mentioned in my comment, you are not properly handling the "Going out of the error handler". You can look Good Patterns For VBA Error Handling for some details on how handling errors.
This code should solve your problem (but I didn't test it)
Sub lars_ake_copy_rows_to_sheets()
Dim firstrow As Long, lastrow As Long, r As Long, torow As Long
Dim fromsheet As Worksheet, tosheet As Worksheet
firstrow = 2
Set fromsheet = ActiveSheet
lastrow = ActiveSheet.Cells(Rows.Count, "P").End(xlUp).Row
For r = firstrow To lastrow
If fromsheet.Cells(r, "P") <> "" Then 'skip rows where column P is empty
On Error GoTo make_new_sheet
Set tosheet = Worksheets("" & fromsheet.Cells(r, "P"))
On Error GoTo 0
torow = tosheet.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
fromsheet.Cells(r, 1).EntireRow.Copy
tosheet.Cells(torow, 1).PasteSpecial Paste:=xlPasteValues
End If
Next r
Application.CutCopyMode = False
fromsheet.Activate
Exit Sub
make_new_sheet:
Set tosheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
tosheet.Name = fromsheet.Cells(r, "P")
resume next
End Sub