I have a VBA question and looking for the most effective way to do this.
I have a table and in Column L is a list of facilities for sales. I am trying to delete all duplicates of the same facility after the first 5. Some facilities have 2 rows, some have 20 so my original thought and experience in VBA of looping through runs into a roadblock.
This sheet is also > 100,000 rows so would take a long, long time.
The sheet would look something like this in column L:
Appreciate all help in advance, looking forward to learning something new here!
Remove Too Many Duplicates
Before
After
The Code
Sub RemoveTooManyDupes()
Const WS_NAME As String = "Sheet1"
Const CRITERIA_COLUMN As Long = 12
Const MAX_DUPES_COUNT As Long = 2
Const DELETE_CRITERION As String = "Nope"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets(WS_NAME)
If ws.FilterMode Then ws.ShowAllData
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
Dim rCount As Long: rCount = rg.Rows.Count
Dim cCount As Long: cCount = rg.Columns.Count + 1 ' extend by one column
Dim erg As Range: Set erg = rg.Resize(, cCount) ' extended range
Dim ecrg As Range: Set ecrg = erg.Columns(cCount) ' extended (last) column
Application.ScreenUpdating = False
ecrg.Value = ws.Evaluate("Row(1:" & rg.Rows.Count & ")") ' integer sequence
Dim crg As Range: Set crg = rg.Columns(CRITERIA_COLUMN) ' criteria column
Dim Data(): Data = crg.Value ' criteria data
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long, rString As String
For r = 2 To rCount
rString = CStr(Data(r, 1))
dict(rString) = dict(rString) + 1
If dict(rString) > MAX_DUPES_COUNT Then Data(r, 1) = DELETE_CRITERION
Next r
crg.Value = Data
erg.Sort crg, xlAscending, , , , , , xlYes
Dim edrg As Range: Set edrg = erg.Resize(rCount - 1).Offset(1) ' no headers
erg.AutoFilter CRITERIA_COLUMN, DELETE_CRITERION ' note 'erg'
Dim vrg As Range ' visible range (filtered rows)
On Error Resume Next
Set vrg = edrg.SpecialCells(xlCellTypeVisible) ' note 'edrg'
On Error GoTo 0
ws.AutoFilterMode = False
If Not vrg Is Nothing Then vrg.Delete xlShiftUp
erg.Sort ecrg, xlAscending, , , , , , xlYes
ecrg.ClearContents
Application.ScreenUpdating = True
MsgBox "Too many dupes removed.", vbInformation
End Sub
Related
So Reference to My old question here that was solved by #VBasic2008, it worked quite well.
Loop Filter data and copy it with header to a new sheet
Now I wonder if I can tweak this code to filter two criteria instead of 1, as I need to filter column A also which contains my company codes (it's not unique values but repetitive like UK1, UK2, and so on. I want to filter for UK1 in column A first then Filter the unique values in column D in a loop and copy data to a new sheet.
with the code mentioned below or in the link shared, it filters only the unique values in column D and copies it to a new sheet.
I need to filter columns A and Column D as per the below screenshot. My columns that contain the data go from A to Z
Code:
Sub CreateSummary()
' Define constants.
' Source
Const SOURCE_NAME As String = "Sheet1"
Const SOURCE_FIRST_CELL_ADDRESS As String = "A1"
Const SOURCE_FILTER_COLUMN_INDEX As Long = 4
' Destination
Const DESTINATION_NAME As String = "Sheet2"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_GAP As Long = 1 ' empty rows in-between
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_NAME)
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range
Set srg = sws.Range(SOURCE_FIRST_CELL_ADDRESS).CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
If srCount = 1 Then Exit Sub ' only headers or empty worksheet
Dim scCount As Long: scCount = srg.Columns.Count
If scCount < SOURCE_FILTER_COLUMN_INDEX Then Exit Sub ' too few columns
' Write the values from the filter column ('srfg') to an array ('sData').
Dim sfrg As Range: Set sfrg = srg.Columns(SOURCE_FILTER_COLUMN_INDEX)
Dim sData() As Variant: sData = sfrg.Value
' Return the unique values and their number of occurrences
' in a dictionary ('dict').
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim sString As String
Dim sr As Long
For sr = 2 To srCount
sString = CStr(sData(sr, 1))
If Len(sString) > 0 Then dict(sString) = dict(sString) + 1 ' count
Next sr
If dict.Count = 0 Then Exit Sub ' only error values or blanks
Erase sData
' Reference the first destination cell ('dCell').
Application.ScreenUpdating = False
Dim dsh As Object
On Error Resume Next
Set dsh = wb.Sheets(DESTINATION_NAME)
On Error GoTo 0
If Not dsh Is Nothing Then
Application.DisplayAlerts = False
dsh.Delete
Application.DisplayAlerts = True
End If
Dim dws As Worksheet: Set dws = wb.Worksheets.Add(After:=sws)
dws.Name = DESTINATION_NAME
Dim dCell As Range: Set dCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
' Copy column widths.
srg.Rows(1).Copy
dCell.Resize(, scCount).PasteSpecial xlPasteColumnWidths
dCell.Select
' Copy the filtered ranges one below the other.
Dim sKey As Variant
For Each sKey In dict.Keys
srg.AutoFilter SOURCE_FILTER_COLUMN_INDEX, sKey
srg.Copy dCell
sws.ShowAllData
Set dCell = dCell.Offset(DESTINATION_GAP + dict(sKey) + 1)
Next sKey
sws.AutoFilterMode = False
'wb.Save
Application.ScreenUpdating = True
' Inform.
MsgBox "Summary created.", vbInformation
End Sub
Please, test the next updated code. It uses other two dictionaries (one for unique company codes and another one to keep the occurrences for each combination Company code - Filter criteria:
Sub CreateSummaryTwoFilters()
Const SOURCE_NAME As String = "Sheet1"
Const SOURCE_FIRST_CELL_ADDRESS As String = "A1"
Const FILTER_COLUMN1_INDEX As Long = 1
Const FILTER_COLUMN2_INDEX As Long = 4
' Destination
Const DESTINATION_NAME As String = "Sheet2"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_GAP As Long = 1 ' empty rows in-between
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_NAME)
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range
Set srg = sws.Range(SOURCE_FIRST_CELL_ADDRESS).CurrentRegion
Dim srCount As Long: srCount = srg.rows.count
If srCount = 1 Then Exit Sub ' only headers or empty worksheet
Dim scCount As Long: scCount = srg.Columns.count
If scCount < FILTER_COLUMN2_INDEX Then Exit Sub ' too few columns
'place all the range in an array for faster iteration:
Dim sData() As Variant: sData = srg.Value
' Return the unique values of cells in A:A and D:D and the number of occurrences for each concatenated pair:
Dim dictA As Object: Set dictA = CreateObject("Scripting.Dictionary")
dictA.CompareMode = vbTextCompare
Dim dictD As Object: Set dictD = CreateObject("Scripting.Dictionary")
dictD.CompareMode = vbTextCompare
Dim dictAD As Object: Set dictAD = CreateObject("Scripting.Dictionary")
dictAD.CompareMode = vbTextCompare
Dim sString As String, sr As Long
For sr = 2 To srCount
sString = CStr(sData(sr, FILTER_COLUMN2_INDEX))
If Len(sData(sr, 1)) > 0 Then dictA(sData(sr, 1)) = vbNullString
If Len(sString) > 0 Then dictD(sString) = vbNullString
dictAD(sData(sr, 1) & "_" & sData(sr, 4)) = dictAD(sData(sr, 1) & "_" & sData(sr, 4)) + 1 'count rows of both occurrence on the same row
Next sr
Application.ScreenUpdating = False
Dim dws As Worksheet
On Error Resume Next
Set dws = wb.Sheets(DESTINATION_NAME)
On Error GoTo 0
If Not dws Is Nothing Then
dws.cells.ClearContents
Else
Set dws = wb.Worksheets.Add(After:=sws)
dws.name = DESTINATION_NAME
End If
Dim dCell As Range: Set dCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
' Copy column widths.
srg.rows(1).Copy ' copy the headers columns width
dCell.Resize(, scCount).PasteSpecial xlPasteColumnWidths
' Copy the filtered ranges one after the other.
Dim sKeyA As Variant, sKeyD As Variant
For Each sKeyA In dictA.Keys 'iterate between each key of company codes dictionary
For Each sKeyD In dictD.Keys 'Iterate between each key of D:D criteria dictionary
srg.AutoFilter FILTER_COLUMN1_INDEX, sKeyA 'place the filters:
srg.AutoFilter FILTER_COLUMN2_INDEX, sKeyD
srg.Copy dCell 'copy the filtered range
'if no any filter row resulted, writhe the keys combination on the headers row (after the last column):
If dictAD(sKeyA & "_" & sKeyD) = "" Then dCell.Offset(, scCount).Value = sKeyA & "_" & sKeyD
sws.ShowAllData:
Set dCell = dCell.Offset(DESTINATION_GAP + dictAD(sKeyA & "_" & sKeyD) + 1) 'reinitialize the cell where to paste next time
Next sKeyD
Next sKeyA
sws.AutoFilterMode = False
'wb.Save
Application.ScreenUpdating = True
' Inform.
dws.Activate
MsgBox "Summary created.", vbInformation
End Sub
Please, send some feedback after testing it.
Edited:
Please, test the next version, which should do what (I understood) you need. I had some problems with the fact that the code used to stop after inserting a worksheet... I added code lines to stop events, calculation etc.:
Sub CreateSummaryTwoFiltersPerCompCode()
Const SOURCE_NAME As String = "Sheet1"
Const SOURCE_FIRST_CELL_ADDRESS As String = "A1"
Const FILTER_COLUMN1_INDEX As Long = 1
Const FILTER_COLUMN2_INDEX As Long = 4
' Destination
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_GAP As Long = 1 ' empty rows in-between
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_NAME)
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range
Set srg = sws.Range(SOURCE_FIRST_CELL_ADDRESS).CurrentRegion
Dim srCount As Long: srCount = srg.rows.count
If srCount = 1 Then Exit Sub ' only headers or empty worksheet
Dim scCount As Long: scCount = srg.Columns.count
If scCount < FILTER_COLUMN2_INDEX Then Exit Sub ' too few columns
'place all the range in an array for faster iteration:
Dim sData() As Variant: sData = srg.Value
' Return the unique values of cells in A:A and D:D and the number of occurrences for each concatenated pair:
Dim dictA As Object: Set dictA = CreateObject("Scripting.Dictionary")
dictA.CompareMode = vbTextCompare
Dim dictD As Object: Set dictD = CreateObject("Scripting.Dictionary")
dictD.CompareMode = vbTextCompare
Dim dictAD As Object: Set dictAD = CreateObject("Scripting.Dictionary")
dictAD.CompareMode = vbTextCompare
Dim sString As String, sr As Long
For sr = 2 To srCount
sString = CStr(sData(sr, FILTER_COLUMN2_INDEX))
If Len(sData(sr, 1)) > 0 Then dictA(sData(sr, 1)) = vbNullString
If Len(sString) > 0 Then dictD(sString) = vbNullString
dictAD(sData(sr, 1) & "_" & sData(sr, 4)) = dictAD(sData(sr, 1) & "_" & sData(sr, 4)) + 1 'count rows of both occurrence on the same row
Next sr
Application.ScreenUpdating = False
' Copy the filtered ranges one after the other.
Dim sKeyA As Variant, sKeyD As Variant, dws As Object, dCell As Range
For Each sKeyA In dictA.Keys 'iterate between each key of company codes dictionary
'insert a new sheet per company code:
Set dws = Nothing
On Error Resume Next
Set dws = wb.Sheets(sKeyA)
On Error GoTo 0
If Not dws Is Nothing Then
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
End If
'a lot of measures to avoid stopping the code after the sheet insertion...
Application.EnableEvents = False: Application.Calculation = xlCalculationManual
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Set dws = wb.Worksheets.Add(After:=sws)
dws.name = sKeyA
DoEvents
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.EnableEvents = True: Application.Calculation = xlCalculationAutomatic
Set dCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
' Copy column widths.
srg.rows(1).Copy ' copy the headers columns width
dCell.Resize(, scCount).PasteSpecial xlPasteColumnWidths
For Each sKeyD In dictD.Keys 'Iterate between each key of D:D criteria dictionary
srg.AutoFilter FILTER_COLUMN1_INDEX, sKeyA 'place the filters:
srg.AutoFilter FILTER_COLUMN2_INDEX, sKeyD
If dictAD(sKeyA & "_" & sKeyD) <> "" Then
srg.Copy dCell 'copy the filtered range
sws.ShowAllData
Set dCell = dCell.Offset(DESTINATION_GAP + dictAD(sKeyA & "_" & sKeyD) + 1) 'reinitialize the cell where to paste next time
End If
Next sKeyD
Next sKeyA
sws.AutoFilterMode = False
'wb.Save
Application.ScreenUpdating = True
' Inform.
dws.Activate
MsgBox "Summary created.", vbInformation
End Sub
I am trying to copy from one worksheet named "List" to five worksheets named "First Upload", "Second Upload", "Third Upload", "Fourth Upload", and "Fifth Upload". I need to copy row 2 to "First Upload" row 3 to "Second Upload", row 4 to "Third Upload" etc. then loop through to the end of the worksheet (around 20,000 rows).
I am trying to end with roughly the same amount of rows on the multiple upload sheets and I need to separate them in this way due to requirements of the system I am using.
I am using the following code and it works for the first upload but brings too many results for the rest of the worksheets(ie double for the "Second Upload", triple for the "Third Upload". The code I am using is:
Sub OffsetTrial()
Dim X As Long, LastRow As Long
Dim CopyRange As Range
LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
For X = 2 To LastRow Step 5
If CopyRange Is Nothing Then
Set CopyRange = Rows(X).EntireRow
Else
Set CopyRange = Union(CopyRange, Rows(X).EntireRow)
End If
Next
If Not CopyRange Is Nothing Then
CopyRange.Copy Destination:=Sheets("First Upload").Range("A2")
End If
LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
For X = 3 To LastRow Step 5
If CopyRange Is Nothing Then
Set CopyRange = Rows(X).EntireRow
Else
Set CopyRange = Union(CopyRange, Rows(X).EntireRow)
End If
Next
If Not CopyRange Is Nothing Then
CopyRange.Copy Destination:=Sheets("Second Upload").Range("A2")
End If
LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
For X = 4 To LastRow Step 5
If CopyRange Is Nothing Then
Set CopyRange = Rows(X).EntireRow
Else
Set CopyRange = Union(CopyRange, Rows(X).EntireRow)
End If
Next
If Not CopyRange Is Nothing Then
CopyRange.Copy Destination:=Sheets("Third Upload").Range("A2")
End If
LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
For X = 5 To LastRow Step 5
If CopyRange Is Nothing Then
Set CopyRange = Rows(X).EntireRow
Else
Set CopyRange = Union(CopyRange, Rows(X).EntireRow)
End If
Next
If Not CopyRange Is Nothing Then
CopyRange.Copy Destination:=Sheets("Fourth Upload").Range("A2")
End If
LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
For X = 6 To LastRow Step 5
If CopyRange Is Nothing Then
Set CopyRange = Rows(X).EntireRow
Else
Set CopyRange = Union(CopyRange, Rows(X).EntireRow)
End If
Next
If Not CopyRange Is Nothing Then
CopyRange.Copy Destination:=Sheets("Fifth Upload").Range("A2")
End If
End Sub
I thought that, in example, in the first part For X = 2 To LastRow Step 5 would start me at row 2 and offset 5 rows then For X = 3 To LastRow Step 5 would start me at row 3 and offset 5 rows but I think I was mistaken or I can't repeat the code like this. Any help with this would be greatly appreciated. Thank you
Split Data Into Multiple Worksheets
Adjust the source worksheet name (sName).
Sub SplitUploads()
' Define constants.
' Source
Const sName As String = "Sheet1"
' Destination
Dim dwsLefts() As Variant
dwsLefts = VBA.Array("First", "Second", "Third", "Fourth", "Fifth")
Const dwsRight As String = " Upload"
Const dFirstCellAddress As String = "A2"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Application.ScreenUpdating = False
' Turn off AutoFilter.
If sws.AutoFilterMode Then sws.AutoFilterMode = False
' Reference the source (table) range ('srg') (has headers).
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
' Write the source number of rows and columns
' to variables ('srCount','scCount').
Dim srCount As Long: srCount = srg.Rows.Count
Dim scCount As Long: scCount = srg.Columns.Count
' Reference the source data range ('sdrg') (no headers).
Dim sdrg As Range: Set sdrg = srg.Resize(srCount - 1).Offset(1)
' Reference the source integer sequence data range ('sidrg') (no headers).
Dim sidrg As Range: Set sidrg = sdrg.Resize(, 1).Offset(, scCount)
' Fill the source integer sequence range with an ascending integer sequence.
sidrg.Value = sws.Evaluate("ROW(1:" & srCount - 1 & ")")
' Write the upper limit of the lefts array
' (destination worksheets left names) to a variable ('cUpper').
Dim cUpper As Long: cUpper = UBound(dwsLefts)
' Reference the source groups sequence data range ('sgdrg') (no headers).
Dim sgdrg As Range: Set sgdrg = sidrg.Offset(, 1)
' Fill the groups sequence range with the groups sequence.
sgdrg.Value = sws.Evaluate("MOD(" & sidrg.Address(0, 0) & "-1," _
& CStr(cUpper + 1) & ")+1")
' Reference the source expanded range ('serg'), the source range
' including the two additional columns (has headers).
Dim serg As Range: Set serg = srg.Resize(, scCount + 2)
' Sort the source expanded range ascending by the groups sequence column
' so when the range is being filtered, there is only one area.
serg.Sort serg.Columns(scCount + 2), xlAscending, , , , , , xlYes
Dim dws As Worksheet
Dim dfCell As Range
Dim sfrg As Range
Dim c As Long
' Loop through the elements of the lefts array.
For c = 0 To cUpper
' Reference the current destination worksheet ('dws').
Set dws = wb.Worksheets(dwsLefts(c) & dwsRight)
' Reference the destination first cell.
Set dfCell = dws.Range(dFirstCellAddress)
' Clear previous data.
dfCell.Resize(dws.Rows.Count - dfCell.Row + 1, _
dws.Columns.Count - dfCell.Column + 1).Clear
' Filter the expanded range by the current group ('c + 1').
serg.AutoFilter scCount + 2, c + 1
' Attempt to reference the source filtered range ('sfrg')
' (additional columns not included) (no headers).
On Error Resume Next
Set sfrg = sdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' Turn off the autofilter.
sws.AutoFilterMode = False
' Copy.
If Not sfrg Is Nothing Then ' filtered data is present
' Copy the source filtered range to the destination worksheet.
sfrg.Copy Destination:=dfCell
Set sfrg = Nothing ' reset the source filtered range variable
'Else ' no filtered data; do nothing
End If
Next c
' Sort the source expanded range ascending by the integer sequence column
' so the data gets back to its original rows.
serg.Sort serg.Columns(scCount + 1), xlAscending, , , , , , xlYes
' Clear the additional columns.
Union(sidrg, sgdrg).ClearContents
' Save the workbook.
'wb.Save
Application.ScreenUpdating = True
' Inform.
MsgBox "Uploads split.", vbInformation
End Sub
FYI your problem is that you're not setting CopyRange to Nothing between each of the For X =... blocks, so you just keep accumulating rows instead of starting fresh.
You can do this with less code - and more flexibility with how many upload sheets you use - by using an array of ranges, and some minor renaming of your upload sheets:
Sub OffsetTrial()
Const NUM_SHEETS As Long = 3
Const START_ROW As Long = 2
Dim X As Long, ws As Worksheet
Dim ranges(1 To NUM_SHEETS) As Range, shtNum As Long
Set ws = ActiveSheet 'or some specific sheet...
For X = START_ROW To ws.Cells(ws.Cells.Rows.Count, "A").End(xlUp).Row
shtNum = 1 + ((X - START_ROW) Mod NUM_SHEETS) 'which destination sheet?
BuildRange ranges(shtNum), ws.Rows(X)
Next
For X = 1 To NUM_SHEETS
If Not ranges(X) Is Nothing Then
ranges(X).Copy Sheets("Upload " & X).Range("A2")
End If
Next X
End Sub
Sub BuildRange(rngTot As Range, rngToAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngToAdd
Else
Set rngTot = Application.Union(rngTot, rngToAdd)
End If
End Sub
I use this VBA code which works very well. It searches in column A of an external Excel file for all the terms in column D, and replaces the matches, with the content of column B of the external file in the found row. So for instance:
if D5 matches A11 of the external file, then B11 from external file is written to D5.
I am now trying to modify it so that it still searches in column 4 for matches in column A of external file, but for any matches found, replaces the column E with column B of the external file. So:
If D5 matches A11, then B11 from external file is written to E5.
Well, I've tried many changes in the replace loop but it throws errors every time. I suppose I don't use the correct command!
Private Sub CommandButton1_Click()
Dim NameListWB As Workbook, thisWb As Workbook
Dim NameListWS As Worksheet, thisWs As Worksheet
Dim i As Long, lRow As Long
'This is the workbook from where code runs
Set thisWb = ThisWorkbook
Set thisWs = thisWb.Sheets("Sheet1")
'External file
Set NameListWB = Workbooks.Open("E:\Data.xlsx")
Set NameListWS = NameListWB.Worksheets("Sheet1")
With NameListWS
'Detect end row in Col A of Data.xlsx
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'Loop though Column A
For i = 1 To lRow
'... and perform replace action
thisWs.Columns(4).Replace What:=.Range("A" & i).Value, _
Replacement:=.Range("B" & i).Value, _
SearchOrder:=xlByColumns, _
MatchCase:=False
Next i
End With
End Sub ```
Untested:
Private Sub CommandButton1_Click()
Dim NameListWB As Workbook
Dim NameListWS As Worksheet, thisWs As Worksheet, n As Long
Dim i As Long, arrList, arrD, rngD As Range
Set thisWs = ThisWorkbook.Sheets("Sheet1") 'This is the workbook from where code runs
'get an array from the column to be searched
Set rngD = thisWs.Range("D1:D" & thisWs.Cells(Rows.Count, "D").End(xlUp).Row)
arrD = rngD.Value
'Open external file and get the terms and replacements as an array
Set NameListWB = Workbooks.Open("E:\Data.xlsx")
With NameListWB.Worksheets("Sheet1")
arrList = .Range("A1:B" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
For n = 1 To UBound(arrD, 1) 'check each value from ColD
For i = 1 To UBound(arrList, 1) 'loop over the array of terms to search for
If arrD(n, 1) = arrList(i, 1) Then 'exact match ?
'If InStr(1, arrD(n, 1), arr(i, 1)) > 0 Then 'partial match ?
rngD.Cells(n).Offset(0, 1).Value = arrList(i, 2) 'populate value from ColB into ColE
Exit For 'got a match so stop searching
End If
Next i
Next n
End Sub
A VBA Lookup (Application.Match)
Adjust (play with) the values in the constants section.
Compact
Sub VBALookup()
' Source
Const sPath As String = "E:\Data.xlsx"
Const sName As String = "Sheet1"
Const slCol As String = "A" ' lookup
Const svCol As String = "B" ' value
Const sfRow As Long = 2
' Destination
Const dName As String = "Sheet1"
Const dlCol As String = "D" ' lookup
Const dvCol As String = "E" ' value
Const dfRow As Long = 2
Application.ScreenUpdating = False
' Source
Dim swb As Workbook: Set swb = Workbooks.Open(sPath)
Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
If slRow < sfRow Then Exit Sub ' no data in lookup column range
Dim srCount As Long: srCount = slRow - sfRow + 1
Dim slrg As Range: Set slrg = sws.Cells(sfRow, slCol).Resize(srCount)
Dim svData As Variant
With slrg.EntireRow.Columns(svCol)
If srCount = 1 Then ' one cell
ReDim svData(1 To 1, 1 To 1): svData(1, 1) = .Value
Else ' multiple cells
svData = .Value
End If
End With
' Destination
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dlCol).End(xlUp).Row
If dlRow < dfRow Then Exit Sub ' no data in lookup column range
Dim drCount As Long: drCount = dlRow - dfRow + 1
Dim dlrg As Range: Set dlrg = dws.Cells(dfRow, dlCol).Resize(drCount)
Dim dData As Variant
If drCount = 1 Then ' one cell
ReDim dData(1 To 1, 1 To 1): dData(1, 1) = dlrg.Value
Else ' multiple cells
dData = dlrg.Value
End If
' Loop.
Dim srIndex As Variant
Dim dValue As Variant
Dim dr As Long
Dim MatchFound As Boolean
For dr = 1 To drCount
dValue = dData(dr, 1)
If Not IsError(dValue) Then
If Len(dValue) > 0 Then
srIndex = Application.Match(dValue, slrg, 0)
If IsNumeric(srIndex) Then MatchFound = True
End If
End If
If MatchFound Then
dData(dr, 1) = svData(srIndex, 1)
MatchFound = False
Else
dData(dr, 1) = Empty
End If
Next dr
' Close the source workbook.
swb.Close SaveChanges:=False
' Write result.
dlrg.EntireRow.Columns(dvCol).Value = dData
' Inform.
Application.ScreenUpdating = True
MsgBox "VBA lookup has finished.", vbInformation
End Sub
I am trying to clear all of the contents from columns E through AN for only the rows that have data in Column E (and not continue through the rest of the sheet). I would like the formulas in the cells to stay intact.
Any help greatly appreciated!
Sub ClearJEdetails()
Dim rng As Range
Set rng = Range("e12:AI1048530")
'Selecting only hardcoded data
rng.SpecialCells(xlCellTypeConstants).Select
Selection.ClearContents
End Sub
Sub ClearJEformulas()
Dim rng As Range
Set rng = Range("aj13:Ak1048530")
'Selecting only formulas
rng.SpecialCells(xlCellTypeFormulas).Select
Selection.ClearContents
End Sub
Clear Contents of Filtered Rows in Certain Columns
Adjust the values in the constants section.
Option Explicit
Sub DeleteFilteredEntireRows()
Const wsName As String = "Sheet1"
Const hRow As Long = 1
Const lrCol As String = "E"
Const Cols As String = "E:AN"
Const Criteria As String = "<>" ' non-blanks
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
Dim rCount As Long: rCount = lRow - hRow + 1
Dim scrg As Range: Set scrg = ws.Cells(hRow, lrCol).Resize(rCount)
Dim scdrg As Range: Set scdrg = scrg.Resize(rCount - 1).Offset(1)
scrg.AutoFilter 1, Criteria
Dim vcdrg As Range
On Error Resume Next
Set vcdrg = scdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ws.AutoFilterMode = False
If vcdrg Is Nothing Then Exit Sub
Dim drg As Range: Set drg = Intersect(vcdrg.EntireRow, ws.Columns(Cols))
drg.ClearContents
End Sub
I am looking to filter out a set of data with the criteria being if column A has over 5 characters in the string delete it.
However, before I delete it, I want to copy these entries to a sheet named "fixed"
The code I have at the moment works for the first entry, but doesn't loop through and I am unsure how to fix that...
Code:
Dim LR As Long, i As Long
LR = Worksheets("Output Sheet").Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step -1
If Len(Range("A" & i).Value) >= 5 Then
Rows(i).EntireRow.Cut Worksheets("Fixed").Range("A:D")
Rows(i).Delete
End If
Next i
The data it is copying has 4 columns if that's of any help? I just can't seem to figure out why it doens't look but I am nearly positive it's a simple fix so any pointers would be appreciated.
Dim f As Long
Set Rng = Worksheets("Black List").Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
With Worksheets("Output Sheet")
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For f = Lastrow To 1 Step -1
If Not IsError(Application.Match(.Range("A" & f).Value, Rng, 0)) Then
.Rows(f).Delete
End If
Next f
End With
Application.ScreenUpdating = True
Backup Data
This will add a formula (=LEN(A1)) to an inserted column range (E), to calculate the length of the values of the criteria column (A), and filter this range.
The filtered data (sdvrg) will be copied (appended) to another worksheet (Fixed) and the filtered data's entire rows will be deleted.
Finally, the inserted column (E) will be deleted.
Option Explicit
Sub BackupData()
Const sName As String = "Output Sheet"
Const sCols As String = "A:D"
Const scCol As Long = 1 ' Criteria Column
Const shRow As Long = 1 ' Header Row
Const sLenCriteria As String = ">5"
Const dName As String = "Fixed"
Const dCol As String = "A"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
If sws.AutoFilterMode Then sws.AutoFilterMode = False
Dim slRow As Long
With sws.Columns(sCols).Columns(scCol)
slRow = .Cells(.Cells.Count).End(xlUp).Row
End With
If slRow <= shRow Then Exit Sub ' no data or just headers
Dim srCount As Long: srCount = slRow - shRow + 1
' Source Table Range ('strg') (headers)
Dim strg As Range: Set strg = sws.Rows(shRow).Columns(sCols).Resize(srCount)
' Source Data Range ('sdrg') (no headers)
Dim sdrg As Range: Set sdrg = strg.Resize(srCount - 1).Offset(1)
Dim scCount As Long: scCount = strg.Columns.Count
Application.ScreenUpdating = False
' Source Inserted Column Range ('sicrg') (headers)
Dim sicrg As Range: Set sicrg = strg.Columns(1).Offset(, scCount)
sicrg.Insert Shift:=xlShiftToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Set sicrg = sicrg.Offset(, -1) ' account for 'Insert'
' The formula is also written to the header row which is irrelevant
' to the upcoming 'AutoFilter'.
sicrg.Formula = "=LEN(" & strg.Cells(1, scCol).Address(0, 0) & ")"
sicrg.AutoFilter 1, sLenCriteria
' Source Data Visible Range ('sdvrg') (no headers)
Dim sdvrg As Range
On Error Resume Next ' prevent 'No cells found' error.
Set sdvrg = sdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
sws.AutoFilterMode = False
Dim WasBackedUp As Boolean
If Not sdvrg Is Nothing Then
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
If dws.AutoFilterMode Then dws.AutoFilterMode = False
Dim dfCell As Range
Set dfCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Offset(1)
sdvrg.Copy dfCell
sdvrg.EntireRow.Delete Shift:=xlShiftUp ' resizes 'sicrg' appropriately
WasBackedUp = True
End If
sicrg.Delete Shift:=xlShiftToLeft
Application.ScreenUpdating = True
If WasBackedUp Then
MsgBox "Data backed up.", vbInformation
Else
MsgBox "No action taken.", vbExclamation
End If
End Sub