rockatheman
New Member
- Joined
- Jan 28, 2021
- Messages
- 2
- Office Version
- 365
- Platform
- Windows
- I have an "Import" worksheet. On this sheet I have 3 droplists with criterias:
London = C3, High School = C4, Old = C5
City, School and Student are changeable items from a droplist.
- I have a "Specifications" worksheet. On this sheet I have a table which looks like:
The Table starts on the "H" column. (The table has more rows, this is an example from it.)
- On the "Import" worksheet information gets imported in this format:
The Data starts on the "E" column. (Again, this is an example. The real data has more rows.)
- Now coming to the actual problem:
There are 2 types of student numbers. One with letters, One with numbers. Numbers are always a complete match, letters usually a partial match. Numbers are found on "Import" sheet column "H" and letters can be found in "Import" sheet column "M".
When a match is found on the "Import" sheet then copy from "Specifications" sheet table column "City"(H), "School"(I), "Student"(J), "Constant 1"(K), "Constant 2"(L), "Constant 3"(M) and copy from the "Specifications" sheet "Date" (E), "Amount" (K), into a table on the 3rd worksheet called "Output".
The table looks like this:
There won't always be a match with every row on the "Import" worksheet. For those instances where there are rows without a match the row should still be copied to the "Output" table, but with Constant 1,2,3 filled as "Unknown". Like on the image above.
I have the following code:
VBA Code:
Option Explicit
Dim wsImport As Worksheet
Sub Sample()
Dim wsSpec As Worksheet
Set wsImport = ThisWorkbook.Sheets("Import")
Set wsSpec = ThisWorkbook.Sheets("Specifications")
Dim CriteriaA As String, CriteriaB As String, CriteriaC As String
Dim aCell As Range, bCell As Range
Dim origin As String, KeyToFind As String
With wsSpec
CriteriaA = wsImport.Range("C3").Value2
CriteriaB = wsImport.Range("C4").Value2
CriteriaC = wsImport.Range("C5").Value2
'~~> Using .Find to look for CriteriaA
Set aCell = .Columns(8).Find(What:=CriteriaA, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> Check if found or not
If Not aCell Is Nothing Then
Set bCell = aCell
'~~> Secondary checks
If aCell.Offset(, 1).Value2 = CriteriaB And _
aCell.Offset(, 2).Value2 = CriteriaC Then '<~~ If match found
'~~> Get the origin and the key
origin = aCell.Offset(, 6).Value2
KeyToFind = aCell.Offset(, 7).Value2
Else '<~~ If match not found then search for next match
Do
Set aCell = .Columns(8).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
If aCell.Offset(, 1).Value2 = CriteriaB And _
aCell.Offset(, 2).Value2 = CriteriaC Then
origin = aCell.Offset(, 6).Value2
KeyToFind = aCell.Offset(, 7).Value2
Exit Do
End If
Else
Exit Do
End If
Loop
End If
'~~> Check the origin
If origin = "Letters" Then
CopyRows "M", KeyToFind, True
ElseIf origin = "Numbers" Then
CopyRows "H", KeyToFind, False
Else
MsgBox "Please check origin. Numbers/Letters not found. Exiting..."
End If
Else
MsgBox "Criteria A match was not found. Exiting..."
End If
End With
End Sub
'~~> Autofilter and copy filtered data
Private Sub CopyRows(Col As String, SearchString As String, PartialString As Boolean)
Dim copyFrom As Range
Dim lRow As Long
With wsImport
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range(Col & .Rows.Count).End(xlUp).Row
With .Range(Col & "1:" & Col & lRow)
If PartialString = False Then
.AutoFilter Field:=1, Criteria1:=SearchString
Else
.AutoFilter Field:=1, Criteria1:="=*" & SearchString & "*"
End If
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
'~~> Some sheet where you want to paste the output
Dim SomeSheet As Worksheet
Set SomeSheet = ThisWorkbook.Sheets("Output")
If Not copyFrom Is Nothing Then
'~~> Copy and paste to some sheet
copyFrom.Copy SomeSheet.Rows(1)
'After copying, delete the unwanted columns (OPTIONAL)
End If
End SubI hope I have articulated my problem enough. Thanks!
