Excel VBA FiltertoSheets

[minddumps]

Hello all,

This is a question in reference to a macro written by Erik Van Geit here: https://www.mrexcel.com/forum/excel...t-based-criteria-post3392362.html#post3392362

When I run the macro the header is copied over to it's appropriate sheet, but the data matching does not with the exception of the first array. In my worksheet, Col B has names matching the 4 sheets listed in the macro. I need the entire row that matches the name of the sheet to move to that sheet for all the arrays. I'd greatly appreciate some editing please. Please keep in mind I am a novice when it comes to VBA, I copy and paste and then try to understand each component haha.

I'm using Excel 2010 on a Windows 10 system btw

Sub STEP5_Filter_To_Separate_Data_to_Sheets()
'Erik Van Geit
'1302013 2118
'lacks error handling when sheet doesn't exist
'clearing sheets and pasting with columnheaders
'https://www.mrexcel.com/forum/excel-questions/685493-vba-move-rows-another-sheet-based-criteria.html

Dim SourceSheet As Worksheet
Dim TargetSheet As Worksheet
Dim SheetNames As Variant
Dim i As Long
Dim LR As Long

'EDIT
Set SourceSheet = Sheets("Sheet1")
SheetNames = Array("STN", "CO", "BN", "BDE")
Const FilterColumn = 2 'I don't understand what this represents, I assumed column number of where to look for the array
'END EDIT

    With SourceSheet
    LR = .Range("B" & .Rows.Count).End(xlUp).Row
    
        For i = 0 To UBound(SheetNames)
        Set TargetSheet = Worksheets(SheetNames(i))
        TargetSheet.Cells.ClearContents
        
            With .Range("A1:W" & LR)
            .AutoFilter Field:=FilterColumn, Criteria1:=SheetNames(i)
            .Offset(0, 0).Copy TargetSheet.Range("A1")
            End With
        Next i

    End With

End Sub

 

[JackDanIce]

Welcome to the board. I believe the code you're using isn't copying the filtered visible cells only, try:

Sub Macro1()
    
    Dim arr()   As Variant: arr = Array("STN", "CO", "BN", "BDE")
    Dim x       As Long
    Dim LR      As Long
    
    Const ColumnToFilter    As Long = 2
    
    Application.ScreenUpdating = False
    
    With sheets("Sheet1")
        If .AutoFilterMode Then .AutoFilterMode = False
        LR = .Cells(.Rows.Count, ColumnToFilter).End(xlUp).Row
        For x = LBound(arr) To UBound(arr)
            sheets(arr(x)).Cells.ClearContents
            With .Cells(1, 1).Resize(LR, 23)
                .AutoFilter field:=ColumnToFilter, Criteria1:=arr(x)
                .SpecialCells(xlCellTypeVisible).Copy sheets(arr(x)).Cells(1, 1)
            End With
            Application.CutCopyMode = False
        Next x
        .AutoFilterMode = False
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    
End Sub

 

[minddumps]

That did the trick. It worked perfectly like I was expecting... thank you so much for taking the time to share that!

Welcome to the board. I believe the code you're using isn't copying the filtered visible cells only, try:

Sub Macro1()
    
    Dim arr()   As Variant: arr = Array("STN", "CO", "BN", "BDE")
    Dim x       As Long
    Dim LR      As Long
    
    Const ColumnToFilter    As Long = 2
    
    Application.ScreenUpdating = False
    
    With sheets("Sheet1")
        If .AutoFilterMode Then .AutoFilterMode = False
        LR = .Cells(.Rows.Count, ColumnToFilter).End(xlUp).Row
        For x = LBound(arr) To UBound(arr)
            sheets(arr(x)).Cells.ClearContents
            With .Cells(1, 1).Resize(LR, 23)
                .AutoFilter field:=ColumnToFilter, Criteria1:=arr(x)
                .SpecialCells(xlCellTypeVisible).Copy sheets(arr(x)).Cells(1, 1)
            End With
            Application.CutCopyMode = False
        Next x
        .AutoFilterMode = False
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    
End Sub

 

[JackDanIce]

You're welcome.

 

[minddumps]

Oh boy... I just tested again after clearing all steps I ran from the sheet and I'm getting the everything copies to only one sheet again... this time to the BDE sheet. I recopied the code text you originally shared (just in case I messed something up) but it didn't work again. Errrgggg

Here is what I have for all the steps just in case something in a previous macro is messing it up. Do you mind glancing through to see what may be causing the issues?

Sub Run_ALL()
'
' All_Steps_TEST Macro
'

'
   Call STEP1_conditional_color_seperating_RSIDs
   Call STEP2_Adding_Column_and_Formula
   Call STEP3_Fill_Formula_through_last_row
   Call STEP4_Copy_Formulas_Paste_Values
   Call STEP5_Create_Sheets_in_prep_to_separate
   Call STEP6_Filter_To_Separate_Data_to_Sheets
   Call STEP7_Process_End_message
   
   
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP1_conditional_color_seperating_RSIDs()

'---Variables---
Dim myRange As Range

'---Customize---
Set myRange = ActiveWorkbook.Sheets("Sheet1").Range("A:W") 'The range to be formatted

'---Logic---
myRange.FormatConditions.Delete 'Clear any existing conditional formatting

'Rules that are up in the list have higher priority
Call FormatRange(myRange, 2, "=($A1)=""Rsid""") 'Header stays white
Call FormatRange(myRange, 43, "=LEN($A1)>3") 'Stations are green and 4 characters
Call FormatRange(myRange, 42, "=AND(LEN($A1)>2,LEN($A1)<4)") 'COs are blue and 3 characters
Call FormatRange(myRange, 44, "=AND(LEN($A1)>1,LEN($A1)<3)") 'BNs are yellow and 2 characters
Call FormatRange(myRange, 45, "=AND(LEN($A1)>0,LEN($A1)<2)") 'BDEs are orance and 1 character
Call FormatRange(myRange, 2, "=($A1)<>""Rsid""") 'Header


    With Sheet1.Range("A1:U1")
        .FormatConditions.Delete
    End With

End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'A support method that makes creating new conditional formats a little easier
Public Sub FormatRange(r As Range, colorIndex As Integer, formula As String)
r.FormatConditions.Add xlExpression, Formula1:=formula
r.FormatConditions(r.FormatConditions.Count).Interior.colorIndex = colorIndex
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP2_Adding_Column_and_Formula()
'
' Adding_Formula Macro
'

    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Unit Name"
    Range("B2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(LEN(RC1)>3,""STN"",IF(AND(LEN(RC1)>2,LEN(RC1)<4),""CO"",IF(AND(LEN(RC1)>1,LEN(RC1)<3),""BN"",IF(AND(LEN(RC1)>0,LEN(RC1)<2),""BDE"",""NA""))))"
    Range("B3").Select

End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP3_Fill_Formula_through_last_row()
'
' Fill_Formula through last row
'

    Range("B2").formula = "=IF(LEN($A2)>3,""STN"",IF(AND(LEN($A2)>2,LEN($A2)<4),""CO"",IF(AND(LEN($A2)>1,LEN($A2)<3),""BN"",IF(AND(LEN($A2)>0,LEN($A2)<2),""BDE"",""NA""))))"
    Range("B2", "B" & Cells(Rows.Count, 1).End(xlUp).Row).FillDown

End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP4_Copy_Formulas_Paste_Values()
'
' Step4_Copy_Formulas_Paste_Values Macro
'

'
    Columns("B:B").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP5_Create_Sheets_in_prep_to_separate()
    With Sheets
        .Add.Name = "STN"
        .Add.Name = "CO"
        .Add.Name = "BN"
        .Add.Name = "BDE"
    End With
    
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP6_Filter_To_Separate_Data_to_Sheets()
    
    Dim arr()   As Variant: arr = Array("STN", "CO", "BN", "BDE")
    Dim x       As Long
    Dim LR      As Long
    
    Const ColumnToFilter    As Long = 2
    
    Application.ScreenUpdating = False
    
    With Sheets("Sheet1")
        If .AutoFilterMode Then .AutoFilterMode = False
        LR = .Cells(.Rows.Count, ColumnToFilter).End(xlUp).Row
        For x = LBound(arr) To UBound(arr)
            Sheets(arr(x)).Cells.ClearContents
            With .Cells(1, 1).Resize(LR, 23)
                .AutoFilter field:=ColumnToFilter, Criteria1:=arr(x)
                .SpecialCells(xlCellTypeVisible).Copy Sheets(arr(x)).Cells(1, 1)
            End With
            Application.CutCopyMode = False
        Next x
        .AutoFilterMode = False
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP7_Process_End_message()
    'Display a message to inform the user the procedure has finished.
    MsgBox "Process Completed.", vbInformation
     
End Sub

 

[minddumps]

Well nevermind... I just opened a brand new excel workbook and retried everything and it's all working as expected again... weird. Well thanks again! Have a fab weekend

Oh boy... I just tested again after clearing all steps I ran from the sheet and I'm getting the everything copies to only one sheet again... this time to the BDE sheet. I recopied the code text you originally shared (just in case I messed something up) but it didn't work again. Errrgggg

Here is what I have for all the steps just in case something in a previous macro is messing it up. Do you mind glancing through to see what may be causing the issues?

Sub Run_ALL()
'
' All_Steps_TEST Macro
'

'
   Call STEP1_conditional_color_seperating_RSIDs
   Call STEP2_Adding_Column_and_Formula
   Call STEP3_Fill_Formula_through_last_row
   Call STEP4_Copy_Formulas_Paste_Values
   Call STEP5_Create_Sheets_in_prep_to_separate
   Call STEP6_Filter_To_Separate_Data_to_Sheets
   Call STEP7_Process_End_message
   
   
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP1_conditional_color_seperating_RSIDs()

'---Variables---
Dim myRange As Range

'---Customize---
Set myRange = ActiveWorkbook.Sheets("Sheet1").Range("A:W") 'The range to be formatted

'---Logic---
myRange.FormatConditions.Delete 'Clear any existing conditional formatting

'Rules that are up in the list have higher priority
Call FormatRange(myRange, 2, "=($A1)=""Rsid""") 'Header stays white
Call FormatRange(myRange, 43, "=LEN($A1)>3") 'Stations are green and 4 characters
Call FormatRange(myRange, 42, "=AND(LEN($A1)>2,LEN($A1)<4)") 'COs are blue and 3 characters
Call FormatRange(myRange, 44, "=AND(LEN($A1)>1,LEN($A1)<3)") 'BNs are yellow and 2 characters
Call FormatRange(myRange, 45, "=AND(LEN($A1)>0,LEN($A1)<2)") 'BDEs are orance and 1 character
Call FormatRange(myRange, 2, "=($A1)<>""Rsid""") 'Header


    With Sheet1.Range("A1:U1")
        .FormatConditions.Delete
    End With

End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'A support method that makes creating new conditional formats a little easier
Public Sub FormatRange(r As Range, colorIndex As Integer, formula As String)
r.FormatConditions.Add xlExpression, Formula1:=formula
r.FormatConditions(r.FormatConditions.Count).Interior.colorIndex = colorIndex
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP2_Adding_Column_and_Formula()
'
' Adding_Formula Macro
'

    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Unit Name"
    Range("B2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(LEN(RC1)>3,""STN"",IF(AND(LEN(RC1)>2,LEN(RC1)<4),""CO"",IF(AND(LEN(RC1)>1,LEN(RC1)<3),""BN"",IF(AND(LEN(RC1)>0,LEN(RC1)<2),""BDE"",""NA""))))"
    Range("B3").Select

End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP3_Fill_Formula_through_last_row()
'
' Fill_Formula through last row
'

    Range("B2").formula = "=IF(LEN($A2)>3,""STN"",IF(AND(LEN($A2)>2,LEN($A2)<4),""CO"",IF(AND(LEN($A2)>1,LEN($A2)<3),""BN"",IF(AND(LEN($A2)>0,LEN($A2)<2),""BDE"",""NA""))))"
    Range("B2", "B" & Cells(Rows.Count, 1).End(xlUp).Row).FillDown

End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP4_Copy_Formulas_Paste_Values()
'
' Step4_Copy_Formulas_Paste_Values Macro
'

'
    Columns("B:B").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP5_Create_Sheets_in_prep_to_separate()
    With Sheets
        .Add.Name = "STN"
        .Add.Name = "CO"
        .Add.Name = "BN"
        .Add.Name = "BDE"
    End With
    
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP6_Filter_To_Separate_Data_to_Sheets()
    
    Dim arr()   As Variant: arr = Array("STN", "CO", "BN", "BDE")
    Dim x       As Long
    Dim LR      As Long
    
    Const ColumnToFilter    As Long = 2
    
    Application.ScreenUpdating = False
    
    With Sheets("Sheet1")
        If .AutoFilterMode Then .AutoFilterMode = False
        LR = .Cells(.Rows.Count, ColumnToFilter).End(xlUp).Row
        For x = LBound(arr) To UBound(arr)
            Sheets(arr(x)).Cells.ClearContents
            With .Cells(1, 1).Resize(LR, 23)
                .AutoFilter field:=ColumnToFilter, Criteria1:=arr(x)
                .SpecialCells(xlCellTypeVisible).Copy Sheets(arr(x)).Cells(1, 1)
            End With
            Application.CutCopyMode = False
        Next x
        .AutoFilterMode = False
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub STEP7_Process_End_message()
    'Display a message to inform the user the procedure has finished.
    MsgBox "Process Completed.", vbInformation
     
End Sub