Looping my macro if cell values are listed.

ahuang3433

New Member
Joined
Jan 24, 2017
Messages
18
Hi,

I have a code here where I want to edit.

On this portion of the code, instead of filter the list all together I want to filter them 1 by 1. Basically Filter A2 value. This piece needs to be variant since the list could range from A2:A50 at times. But I want it to run 1 at a time.

VBA Code:
'Look for Values in List Search

    Dim count As Integer
    Dim list As Variant

    wb1.Activate
    count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))

    list = Split(Join(Application.Transpose(Range(Cells(1, 1), Cells(count, 1)).Value), ","), ",")

'Filter based on List Search Values
    
    WB2.Activate
    Sheets("Latest Material Planning").Activate
    ActiveSheet.Range("A1").AutoFilter Field:=2, Criteria1:=list, Operator:=xlFilterValues

then run the next portion of the code. This portion doesn't require editing I believe.

VBA Code:
'Data Transfer from Latest Material Planning

    Range(Range("B2"), Range("B2").End(xlDown)).Select
    Selection.Copy
    Sheets("Dashboard").Select
    Range("A6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Latest Material Planning").Select
    
    Range(Range("F2"), Range("F2").End(xlDown)).Select
    Selection.Copy
    Sheets("Dashboard").Select
    Range("B6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Latest Material Planning").Select
    
    Range(Range("G2"), Range("G2").End(xlDown)).Select
    Selection.Copy
    Sheets("Dashboard").Select
    Range("C6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Latest Material Planning").Select
    
    Range(Range("M2"), Range("M2").End(xlDown)).Select
    Selection.Copy
    Sheets("Dashboard").Select
    Range("D6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Latest Material Planning").Select
    
    Range(Range("R2"), Range("R2").End(xlDown)).Select
    Selection.Copy
    Sheets("Dashboard").Select
    Range("E6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Latest Material Planning").Select
    
    Range(Range("I2"), Range("I2").End(xlDown)).Select
    Selection.Copy
    Sheets("Dashboard").Select
    Range("F6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Latest Material Planning").Select
    
    Range(Range("S2"), Range("S2").End(xlDown)).Select
    Selection.Copy
    Sheets("Dashboard").Select
    Range("G6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Latest Material Planning").Select
    
    Range(Range("T2"), Range("T2").End(xlDown)).Select
    Selection.Copy
    Sheets("Dashboard").Select
    Range("H6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Latest Material Planning").Select
    
    Range(Range("O2"), Range("O2").End(xlDown)).Select
    Selection.Copy
    Sheets("Dashboard").Select
    Range("J6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Latest Material Planning").Select
    
    Range(Range("AB2"), Range("AB2").End(xlDown)).Select
    Selection.Copy
    Sheets("Dashboard").Select
    Range("K6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("K6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Replace What:="NA", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Sheets("Latest Material Planning").Select
    
    Range(Range("AA2"), Range("AA2").End(xlDown)).Select
    Selection.Copy
    Sheets("Dashboard").Select
    Range("L6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Latest Material Planning").Select
    
    Range(Range("Y2"), Range("Y2").End(xlDown)).Select
    Selection.Copy
    Sheets("Dashboard").Select
    Range("P6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
      
'Add formula's to Dashboard Tab

    Sheets("Dashboard").Select
    Range("N6").Select
    lastRow = Range("A" & Rows.count).End(xlUp).Row
    Range("N6:N" & lastRow) = "=VLOOKUP(RC[-12],'PM List'!C[-13]:C[-10],4,FALSE)"
    
    Range("I6").Select
    lastRow = Range("A" & Rows.count).End(xlUp).Row
    Range("I6:I" & lastRow) = "=IF(LEFT(RC[-7],3)=""TBD"",""Red"",IF(RC[-1]>=0,""Green"",IF(AND(RC[2]<>"""",RC[2]>=RC[1]),""Yellow"",""Red"")))"
    
    Range("B1").Select
    ActiveCell.FormulaR1C1 = _
        "=TEXTJOIN("" | "",TRUE,'List Search'!R[1]C[-1]:R[1048575]C[-1])"
    
'Format Dashboard Tab

    Range("J5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.NumberFormat = "m/d/yyyy"
    Range("A5:Q5").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 12611584
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Columns.AutoFit
    
    Range("I6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""Green"""
    Selection.FormatConditions(Selection.FormatConditions.count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Bold = True
        .Italic = False
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 5287936
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""Yellow"""
    Selection.FormatConditions(Selection.FormatConditions.count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Bold = True
        .Italic = False
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""Red"""
    Selection.FormatConditions(Selection.FormatConditions.count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Bold = True
        .Italic = False
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    
    Sheets("Latest Material Planning").Select
    Range("A1").Select
    Selection.AutoFilter
    Selection.AutoFilter
    
    Sheets("List Search").Select
    Range("A1").Select
    
    Sheets("Dashboard").Select
    Range("A5").Select
    Selection.AutoFilter
    Columns("A:Q").Select
    Selection.Columns.AutoFit
    
'Custom Sort Column "I" in Dashboard Tab
    
    Range("A5").Select
    ActiveWorkbook.Worksheets("Dashboard").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Dashboard").AutoFilter.Sort.SortFields.Add2 Key:= _
        Range("I2:I10000"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder _
        :="Red,Yellow,Green", DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Dashboard").AutoFilter.Sort.SortFields.Add2 Key:= _
        Range("J2:J10000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Dashboard").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ActiveSheet.Range("$A$5:$Q$10000").AutoFilter Field:=2, Criteria1:="=TBD*", _
        Operator:=xlAnd
        
    
    Range("G6", Range("G6").End(xlDown)).SpecialCells(xlCellTypeVisible).Select
    
    Selection.ClearContents
    
    ActiveSheet.Range("$A$5:$Q$10000").AutoFilter Field:=2
    
    Dim rr As Long
    Dim sCell As Range

    rr = Cells(Rows.count, 1).End(3).Row

    For Each sCell In Range("G6:G" & rr)

    If sCell.Value = "" Then

        sCell.Formula = sCell.Formula
        sCell.Value = "=0"
        
    End If
    
Next sCell

    ActiveSheet.Range("$A$5:$Q$10000").AutoFilter Field:=2, Criteria1:="=TBD*", _
        Operator:=xlAnd
    Range("N6", Range("N6").End(xlDown)).SpecialCells(xlCellTypeVisible).Select
    
    Selection.ClearContents
    
    Range("H6", Range("H6").End(xlDown)).SpecialCells(xlCellTypeVisible).Select
    
    Selection.ClearContents
    
    
    Dim lr As Long
    Dim rCell As Range

    lr = Cells(Rows.count, 1).End(3).Row

    For Each rCell In Range("H6:H" & lr)

    If rCell.Value = "" Then

        rCell.Formula = "=RC[-3]*-1"
        rCell.Value = rCell.Value
        
    End If
    
Next rCell
    
    ActiveSheet.Range("$A$5:$Q$10000").AutoFilter Field:=2
    
    Range("A5").Select

The save file piece needs editing. If at all possible it will need to be variant too if I have more than 1 value in column A.

VBA Code:
'Save File based on Cell Value

    Dim path As String
    Dim filename1 As String

    path = "Z:\Other\PjM_Documents\ESR Material Planning\Material Readiness\"

    filename1 = path & Range("A2") & " " & Format(Date, "MM-DD-YY")

    ActiveWorkbook.SaveAs filename1, FileFormat:=52, CreateBackup:=False
    
    ActiveWorkbook.Close

Once I'm done with A2, I want to reopen wb2 and start with A3 value. Obviously only needed.
 

Some videos you may like

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

Watch MrExcel Video

Forum statistics

Threads
1,126,993
Messages
5,622,046
Members
415,875
Latest member
Tarali

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top