I have a code that selects non empty cells in column C. Now If I want to select these cells in my autofilter it only pics the first found value of OutRng. How do i fix this?
Sub SelectNonBlankCells()
Sheets("Rekenblad").Select
Dim Rng As Range
Dim OutRng As Range
Dim xTitle As String
SearchCol = "10"
On Error Resume Next
xTitle = Range("C:C")
Set InputRng = Range("C:C")
For Each Rng In InputRng
If Not Rng.Value = "" Then
If OutRng Is Nothing Then
Set OutRng = Rng
Else
Set OutRng = Application.Union(OutRng, Rng)
End If
End If
Next
If Not (OutRng Is Nothing) Then
OutRng.Copy
Sheets("Plakken").Select
ActiveSheet.Range("$A$1:$K$13").AutoFilter Field:=10, Criteria1:=Array(OutRng) _
, Operator:=xlFilterValues
End If
End Sub
AutoFilter on Multiple (an Array of) Values
Range("C:C") is quite a huge range and it could take ages to get processed.
OutRng.Copy makes no sense unless you plan to copy it somewhere.
Since OutRng is declared as a range, Array(OutRng) is an array containing one element which is the actual range (object, not values).
If a range contains more than one cell and is contiguous (a single range, one area), you can use OutRng.Value but this is a 2D one-based array which in this case (it's one-column array) could be converted to a 1D one-based array using Application.Transpose(OutRng.Value) with its limitations. But since you have combined various cells into a range, it is expected that the range is non-contiguous (has several areas, is a multi-range), you're again at a dead end.
No matter what, it was an interesting try (IMHO).
Option Explicit
Sub FilterRange()
' Source
Const sName As String = "Rekenblad"
Const sCol As String = "C"
Const sfRow As Long = 2
' Destination
Const dName As String = "Plakken"
Const dField As Long = 10
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the Source Range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
'If sws.AutoFilterMode Then sws.AutoFilterMode = False
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sCol).End(xlUp).Row
Dim srCount As Long: srCount = slRow - sfRow + 1
If srCount < 1 Then Exit Sub ' no data
Dim srg As Range: Set srg = sws.Cells(sfRow, sCol).Resize(srCount)
' Write the values from the Source Range to the Source Array ('sData').
Dim sData As Variant
If srCount = 1 Then ' one cell
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else ' multiple cells (in column)
sData = srg.Value
End If
' Write the unique values from the Source Array to the keys
' of a dictionary ('dict').
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' A = a
Dim Key As Variant
Dim r As Long
For r = 1 To srCount
Key = sData(r, 1)
If Not IsError(Key) Then ' not error value
If Len(Key) > 0 Then ' not blank
dict(CStr(Key)) = Empty
'Else ' blank
End If
' Else ' error value
End If
Next r
If dict.Count = 0 Then Exit Sub ' only blanks and error values
' Filter the Destination Range ('drg') by the values in the dictionary.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
If dws.AutoFilterMode Then dws.AutoFilterMode = False ' remove previous
Dim drg As Range: Set drg = dws.Range("A1").CurrentRegion
' If the previous line doesn't work, use another way,
' or revert to the static:
'Set drg = dws.Range("A1:K13")
drg.AutoFilter dField, dict.Keys, xlFilterValues
'dws.activate
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 want to take the active cell in the For Each, "vlookup" it in another sheet, and bring back the value from the cell to the right of it.
The problem is in .find(cell.value).
Option Explicit
Sub EmailRep()
Dim range1, range2, cell As Range
Dim ult_email As String
Dim ult_linha As Integer
Dim linha_atual As Integer
Dim Email_atual As String
Set range2 = Sheets("Planilha1").Range("B2:B21")
Set range1 = Range("D4:D19")
linha_atual = range1.Cells(1, 1).Row
ult_linha = 19
ult_email = Email_atual
Email_atual = ult_email
For Each cell In range1
If cell.Value <> ult_email Then
Email_atual = cell.Value
ult_email = cell.Value
Else
cell.Value = range2.Find(cell.Value).Offset(1, 1)
MsgBox (cell)
End If
linha_atual = linha_atual + 1
Next
End Sub
A VBA Lookup (Loop, Dictionary)
This may not be what you need but check it out. It will return the unique column pairs of one two-column range in another worksheet's two-column range.
Adjust (play with) the values in the constants section (a second worksheet name was never mentioned).
Option Explicit
Sub EmailRep()
' Source (Read)
Const sName As String = "Planilha1"
Const sfCol As String = "A"
Const sfRow As Long = 2
' Destination (Write)
Const dName As String = "Planilha2"
Const dfCol As String = "D"
Const dfRow As Long = 4
Const DoClearBelow As Boolean = True
Const DoSort As Boolean = True
' Both
Const Delimiter As String = "|" ' something that doesn't appear in the data
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sfCol).End(xlUp).Row
Dim srg As Range: Set srg = sws.Range( _
sws.Cells(sfRow, sfCol), sws.Cells(slRow, sfCol)).Resize(, 2)
' Write from the source range to the dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim srrg As Range
Dim sString As String
For Each srrg In srg.Rows ' loop through rows
sString = srrg.Cells(1) & Delimiter & srrg.Cells(2)
dict(sString) = Empty
Next srrg
Dim rCount As Long: rCount = dict.Count
Application.ScreenUpdating = False
' Write from the dictionary to the destination range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim drg As Range: Set drg = dws.Cells(dfRow, dfCol).Resize(rCount, 2)
Dim Key As Variant
Dim r As Long
For Each Key In dict.Keys
r = r + 1
drg.Rows(r).Value = Split(Key, Delimiter)
Next Key
' Clear below.
If DoClearBelow Then
drg.Resize(dws.Rows.Count - drg.Row - rCount + 1).Offset(rCount).Clear
End If
' Sort.
If DoSort Then drg.Sort drg.Columns(1), xlAscending
Application.ScreenUpdating = True
MsgBox "Data created.", vbInformation
End Sub
The macro is working with hard coded inputs but I need loops for debugging and future growth. I don't know the best way to set this up.
Range("b3:b8:) are the cells I would like to loop over.
If cell.value = 1 then
Set var1 = range("a3:aq3") (* This range always has the same row number as cell in loop*)
Set var2 = range("a9:aq9") (*This range always 6 greater than row of cell in loop.)
End if
Next cell
Thanks
Loop Through Rows of a Range
Option Explicit
Sub LoopThroughRows()
Const srgAddress As String = "A3:AQ8"
Const scCol As Long = 2
Const sCriteria As String = "1"
Dim sws As Worksheet: Set sws = ActiveSheet ' improve, e.g.:
'Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
'Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
Dim srg As Range: Set srg = sws.Range(srgAddress) ' last use of 'sws'
Dim srCount As Long: srCount = srg.Rows.Count
Dim srg1 As Range
Dim srg2 As Range
Dim sCell As Range
Dim sr As Long
For Each sCell In srg.Columns(scCol).Cells ' don't forget '.Cells'!
sr = sr + 1 ' monitoring each range row (not worksheet row)
If CStr(sCell.Value) = sCriteria Then ' also avoiding error values
Set srg1 = srg.Rows(sr)
Set srg2 = srg1.Offset(srCount)
' Continue... e.g.:
Debug.Print sr, sCell.Address(0, 0), _
srg1.Address(0, 0), srg2.Address(0, 0)
Else ' not equal to sCriteria (usually do nothing)
' e.g.:
Debug.Print sr, sCell.Address(0, 0), "Nope."
End If
Next sCell
End Sub
Have you tried using a for loop?
Eg:
For Each Cell in Range("B3:B8")
If Cell.Value = 1 Then
Set var1 = range("a3:aq3")
Else
Set var2 = range("a9:aq9")
End If
Next Cell
Here is a walkthrough of the situation:
My excel has 2 tabs, one called AssetName Sheet and the other called AMP Sheet
After clicking a vba button, the user is able to generate names in column B of the AssetName Sheet
I have another button that generates an AMP ID for the user. The easiest way for me to explain how this works is through an Index - Match function
=IFERROR(INDEX('AMP Sheet'!$L:$L,MATCH("*"&B2&"*", 'AMP Sheet'!$B:$B,0)), "Not Found")
Column B in the AssetName Sheet is named GeneratedAssetName and column L in the AMP Sheet is named ID.
So, in this example, My_Sandwich_6S_HeroRegular_Mobile exists in the AMP Sheet. Since this is a match, it will grab the associated ID from the AMP Sheet and copy it over to column E of the AssetName Sheet:
My logic (which does the exact same thing as the function I listed in step 3) is housed within a VBA macro button. The code is shown below:
Sub AMPTabid()
Dim wsAN As Worksheet
Set wsAN = Sheets("AssetName Sheet")
Dim wsAMP As Worksheet
Set wsAMP = Sheets("AMP Sheet")
Dim LastRow As Long
LastRow = wsAN.Cells(wsAN.Rows.Count, 2).End(xlUp).Row
Dim i As Long
For i = 2 To LastRow
Dim rFind As range
Set rFind = wsAMP.Columns(2).Find(what:=wsAN.Cells(i, 2), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
If Not rFind Is Nothing Then
wsAN.Cells(i, 5).Value = rFind.Offset(0, 10).Value
End If
Next i
End Sub
Basically, I would like to use my existing code shown in step 4, but with column Names (rather than column numbers). The names I would like to use are Name and ID from the AMP Sheet.
The .Offset logic in my code is the tricky part, since it's going from column B to Column L in the AMP Sheet, so it count column L as 10, rather than 12.
Thanks!
Find Headers and Lookup Values Using Application.Match
Option Explicit
Sub AMPTabid()
' Source
Const sName As String = "AMP Sheet"
Const slTitle As String = "Name"
Const svTitle As String = "ID"
' Destination
Const dName As String = "AssetName Sheet"
Const dlTitle As String = "Generated Asset Name"
Const dvTitle As String = "AMP ID"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion ' Table Range
Dim shrg As Range: Set shrg = srg.Rows(1) ' Header Range
' Get the column numbers.
Dim slCol As Variant: slCol = Application.Match(slTitle, shrg, 0) ' Lookup
Dim svCol As Variant: svCol = Application.Match(svTitle, shrg, 0) ' Value
' Reference the data ranges.
Dim srCount As Long: srCount = srg.Rows.Count - 1
Dim sdrg As Range: Set sdrg = srg.Resize(srCount).Offset(1) ' Data Range
' Lookup Column Range ('Application.Match' works faster with ranges)
Dim slrg As Range: Set slrg = sdrg.Columns(slCol) ' lookup stays in range
Dim svrg As Range: Set svrg = sdrg.Columns(svCol) ' Value Range
Dim svData As Variant: svData = svrg.Value ' value data to array
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim drg As Range: Set drg = dws.Range("A1").CurrentRegion ' Table Range
Dim dhrg As Range: Set dhrg = drg.Rows(1) ' Header Range
' Get the column numbers.
Dim dlCol As Variant: dlCol = Application.Match(dlTitle, dhrg, 0) ' Lookup
Dim dvCol As Variant: dvCol = Application.Match(dvTitle, dhrg, 0) ' Value
' Reference the data ranges.
Dim drCount As Long: drCount = drg.Rows.Count - 1
Dim ddrg As Range: Set ddrg = drg.Resize(drCount).Offset(1) ' Data Range
Dim dlrg As Range: Set dlrg = ddrg.Columns(dlCol) ' Lookup Range
' The same array will be used for lookup and values (results).
Dim dData As Variant: dData = dlrg.Value ' lookup data to array
Dim dvrg As Range: Set dvrg = ddrg.Columns(dvCol) ' to be written to
Dim sIndex As Variant ' Source Lookup (and Value) Index
Dim dlValue As Variant ' Destination Lookup Value
Dim dr As Long
For dr = 1 To drCount
dlValue = dData(dr, 1)
If Not IsError(dlValue) Then ' exclude error values
If Len(dlValue) > 0 Then ' exclude blanks
sIndex = Application.Match(dlValue, slrg, 0)
If IsNumeric(sIndex) Then ' match found
dData(dr, 1) = svData(sIndex, 1)
Else ' no match found
dData(dr, 1) = Empty
End If
End If
End If
Next dr
dvrg.Value = dData
MsgBox "Ids updated.", vbInformation
End Sub
I have below code which is working fine with one sheet data i.e on sheet 2, now i wanted to run same code on other worksheet too i.e sheet 4, sheet 5, sheet 6 and sheet 7 to cut the data from these sheet and paste it in sheet 3 as per below codes.
the below code will work as below
I have master Data in Sheet 2 (Column B) and search criteria in Sheet 1 (Column A), i want VBA to find all the data from Sheet 1 (Column A) in Sheet 2 (Column B) if found cut the entire row and past it into Sheet 3 next available row.
i wanted to run same code on other worksheet too i.e sheet 4, sheet 5, sheet 6 and sheet 7 to cut the data from these sheet and paste it in sheet 3 as per below codes.
Option Explicit
Sub remDup()
' Constants
Const sName As String = "Sheet1"
Const sFirst As String = "A1"
Const lName As String = "Sheet2"
Const lFirst As String = "B1"
Const dName As String = "Sheet3"
Const dFirst As String = "A1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets(lName)
Dim srg As Range: Set srg = refColumn(sws.Range(lFirst))
If srg Is Nothing Then Exit Sub
Dim sData As Variant: sData = getColumn(srg)
' Lookup
Dim lws As Worksheet: Set lws = wb.Worksheets(sName)
Dim lrg As Range: Set lrg = refColumn(lws.Range(sFirst))
If lrg Is Nothing Then Exit Sub
Dim lData As Variant: lData = getColumn(lrg)
' Match
Dim trg As Range
Dim i As Long
For i = 1 To UBound(sData)
If foundMatchInVector(sData(i, 1), lData) Then
Set trg = getCombinedRange(trg, srg.Cells(i))
End If
Next i
' Destination
If Not trg Is Nothing Then
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' This is a kind of a ridiculous use of "refColumn".
Dim drg As Range: Set drg = refColumn(dws.Range(dFirst))
If drg Is Nothing Then
Set drg = dws.Range(dFirst).EntireRow
Else
Set drg = drg.Cells(drg.Cells.Count).Offset(1).EntireRow
End If
trg.EntireRow.Copy drg
trg.EntireRow.Delete
End If
End Sub
' Assumptions: 'FirstCellRange' is a one-cell range e.g. 'Range("A1")'.
' Returns: Either the range from 'FirstCellRange' to the bottom-most
' non-empty cell in the column, or 'Nothing' if all cells
' below 'FirstCellRange' (incl.) are empty.
Function refColumn( _
ByVal FirstCellRange As Range) _
As Range
With FirstCellRange
Dim cel As Range
Set cel = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If Not cel Is Nothing Then
Set refColumn = .Resize(cel.Row - .Row + 1)
End If
End With
End Function
' Assumptions: 'rg' is a one-column range e.g. 'Range("A1")', 'Range("A1:A2")'.
' Returns: A 2D one-based one-column array.
Function getColumn( _
rg As Range) _
As Variant
If rg.Rows.Count > 1 Then
getColumn = rg.Value
Else
Dim OneElement As Variant: ReDim OneElement(1 To 1, 1 To 1)
OneElement(1, 1) = rg.Value
getColumn = OneElement
End If
End Function
' Assumptions: 'MatchValue' is a simple data type (not an object or an array).
' 'Vector' is a structure that 'Application.Match' can handle,
' e.g. a 1D array, a one-column or one-row range or 2D array.
' Returns: 'True' or 'False' (boolean).
' Remarks: Error values and blanks are ignored ('False').
Function foundMatchInVector( _
ByVal MatchValue As Variant, _
ByVal Vector As Variant) _
As Boolean
If Not IsError(MatchValue) Then
If Len(MatchValue) > 0 Then
foundMatchInVector _
= IsNumeric(Application.Match(MatchValue, Vector, 0))
End If
End If
End Function
' Assumptions: 'AddRange' is not 'Nothing' and it is in the same worksheet
' as 'BuiltRange'.
' Returns: A range (object).
Function getCombinedRange( _
ByVal BuiltRange As Range, _
ByVal AddRange As Range)
If BuiltRange Is Nothing Then
Set getCombinedRange = AddRange
Else
Set getCombinedRange = Union(BuiltRange, AddRange)
End If
End Function
Change the constant to a variable and put the main part of your code in a loop. For example (untested)
Option Explicit
Sub remDup()
' Constants
Const sName As String = "Sheet1"
Const sFirst As String = "A1"
'Const lName As String = "Sheet2"
Const lFirst As String = "B1"
Const dName As String = "Sheet3"
Const dFirst As String = "A1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Lookup
Dim lws As Worksheet: Set lws = wb.Worksheets(sName)
Dim lrg As Range: Set lrg = refColumn(lws.Range(sFirst))
If lrg Is Nothing Then Exit Sub
Dim lData As Variant: lData = getColumn(lrg)
' Match
Dim trg As Range
Dim i As Long
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim drg As Range: Set drg = refColumn(dws.Range(dFirst))
' Source
Dim sws As Worksheet
Dim srg As Range:
Dim sData As Variant
Dim lname As Variant
For Each lname In Array("Sheet2", "Sheet4", "Sheet5", "Sheet6", "Sheet7")
' Source
Set sws = wb.Worksheets(lname)
Set srg = refColumn(sws.Range(lFirst))
If Not srg Is Nothing Then
sData = getColumn(srg)
' Match
For i = 1 To UBound(sData)
If foundMatchInVector(sData(i, 1), lData) Then
Set trg = getCombinedRange(trg, srg.Cells(i))
End If
Next i
' Destination
If Not trg Is Nothing Then
trg.EntireRow.Copy drg
trg.EntireRow.Delete
Set drg = drg.Offset(1)
End If
End If
Next
End Sub