Hello - have a real big head scratcher trying to streamline a process. I am looking for a way to filter data in another sheet based off of a criteria in another sheet. explanation below:
my file and data is huge so going to keep it simple below. so lets just say below is sheet A. in another workbook i have only the Unique values in common with sheet A, and that workbook B i need to filter down to what my criteria is in sheet A, for example workbook B will have (123.234.456.555.666) in it. so part of the code would be to filter down that workbook based off of the criteria filter in sheet A. I attached my existing code - it looks like a lot but it really just formats and exports a file. any help is appreciated I am struggling.
Type | Unique | Criteria for filter |
AA | 123 | AA |
AA | 234 | BB |
AA | 456 | |
BB | 555 | |
CC | 666 |
Code
Option Explicit
Sub CN() Dim sPath As String, sPartial As String, sFName As String Dim rws As Long Application.ScreenUpdating = False 'Clear CV Sheet
With Sheets("CV") .Cells.ClearContents
End With 'Clear CN Upload Sheet
With Sheets("CN") .Range("A2:V" & rows.count).ClearContents
End With sPath = "XXX" ' <<<<< change accordingly sPartial = "ZZZ" & Year(Now) & IIf(Len(Month(Now)) = 1, "0" & Month(Now), Month(Now)) & IIf(Len(Day(Now)) = 1, "0" & Day(Now), Day(Now)) & "*.csv" sFName = Dir(sPath & sPartial) If Len(sFName) > 0 Then Workbooks.OpenText sPath & sFName With Sheets("ZZZ") .Range("A:Z").Copy
End With
Workbooks("NC").Sheets("CV").Range("A1").PasteSpecial
Workbooks("NC").Sheets("CV").Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
CommaDelimited2
Workbooks(sFName).Close SaveChanges:=False
CN_2
Application.ScreenUpdating = True
Else MsgBox "File not found.", vbExclamation End If
Workbooks("NC").Sheets("COMPARE").Activate
End Sub
Sub CommaDelimited2() Columns("A:A").Select Application.CutCopyMode = False Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(3, 1), Array(20, 1), Array(26, 1), Array(27, 1), _ Array(40, 1), Array(41, 1), Array(54, 1), Array(55, 1), Array(62, 1), Array(76, 1), Array( _ 90, 1), Array(103, 1), Array(113, 1), Array(125, 1), Array(136, 1), Array(149, 1), Array( _ 152, 1)), TrailingMinusNumbers:=True
End Sub
Sub CN_2() Dim Sheet As Worksheet Dim FoundRange As Range Dim LastRow As Long Dim rws As Long With Workbooks("NC").Sheets("CV") rws = .Range("B2:B2").End(xlDown).row - 1 Workbooks("NC").Sheets("CN").Range("B2").Resize(rws, 1).Value = .Range("B2").Resize(rws).Value
End With With Workbooks("NC").Sheets("CV") rws = .Range("E2:E2").End(xlDown).row - 1 Workbooks("NC").Sheets("CN").Range("F2").Resize(rws, 1).Value = .Range("E2").Resize(rws).Value
End With With Workbooks("NC").Sheets("CV") rws = .Range("G2:G2").End(xlDown).row - 1 Workbooks("NC").Sheets("CN").Range("H2").Resize(rws, 1).Value = .Range("G2").Resize(rws).Value
End With With Workbooks("NC").Sheets("CV") rws = .Range("R2:R2").End(xlDown).row - 1 Workbooks("NC").Sheets("CN").Range("V2").Resize(rws, 1).Value = .Range("R2").Resize(rws).Value
End With Set Sheet = Worksheets("CN") LastRow = Sheet.Cells(Sheet.rows.count, 2).End(xlUp).row If LastRow < 2 Then Exit Sub On Error Resume Next Set FoundRange = Sheet.Range("B2:B" & LastRow).SpecialCells(xlCellTypeConstants) On Error GoTo 0 If FoundRange Is Nothing Then Exit Sub UpdateColumnValues FoundRange, "A", "MU", LastRow, 2, Sheet, True UpdateColumnValues FoundRange, "C", "F", LastRow, 2, Sheet, True UpdateColumnValues FoundRange, "D", "F", LastRow, 2, Sheet, True UpdateColumnValues FoundRange, "E", "R", LastRow, 2, Sheet, True UpdateColumnValues FoundRange, "J", "NA", LastRow, 2, Sheet, True UpdateColumnValues FoundRange, "M", "NA", LastRow, 2, Sheet, True UpdateColumnValues FoundRange, "N", "#", LastRow, 2, Sheet, True UpdateColumnValues FoundRange, "T", Format(Now, "MM/DD/YY"), LastRow, 2, Sheet, True UpdateColumnValues FoundRange, "U", "US", LastRow, 2, Sheet, True Sheets("CN").Copy
GetNameAndSaveAsCSV2
End Sub
Sub GetNameAndSaveAsCSV2()
Dim oWb As Workbook Dim sMyFile As String Dim sSavedFile As String
sMyFile = "AAA" & "BBB" & Format(Now, "MMDDYY") & ".csv" ' <<< change as required Set oWb = ActiveWorkbook ' <<< change as required
' return with drive:\folder\filename.ext of saved file sSavedFile = FileSaveAs(oWb, sMyFile)
Set oWb = Nothing
End Sub
Display More