copy multiple sheet if cell()>0

Question

I need a little help. It is first time when I write here... usually you are my inspiration, but now i didn't find something to help me.

I have an Excel file with 36 sheets. I want to create a macro to copy each sheet and make it a distinct file. The condition is that the cell(X)value to be >0. I have a problem with if then... that is jumping from first sheet to final sheet... or only saves the first sheet and ignores the other. I put here the script for only two sheet..because is working only at the first. Thanks for help.

Sub Macro3()   
    Sheets("A").Select

    If Range("G4").Value > 0 Then
        Sheets("A").Copy
        ActiveSheet.Range("$B$12:$L$22").AutoFilter Field:=1, Criteria1:="="
        Range("B15:B22").Select
        Selection.SpecialCells(xlCellTypeVisible).Select
        Range("C15").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.SpecialCells(xlCellTypeVisible).Select
        Selection.EntireRow.Delete
        Range("B12").Select
        ActiveSheet.ShowAllData
        
        ChDir "C:\Users\Desktop\POSM"
        ActiveWorkbook.SaveAs (Range("D4").Value), _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
    End If
    
    Sheets("B").Select
    
    If Range("G4").Value > 0 Then
        Sheets("B").Copy
        ActiveSheet.Range("$B$12:$L$22").AutoFilter Field:=1, Criteria1:="="
        Range("B15:B22").Select
        Selection.SpecialCells(xlCellTypeVisible).Select
        Range("C15").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.SpecialCells(xlCellTypeVisible).Select
        Selection.EntireRow.Delete
        Range("B12").Select
        ActiveSheet.ShowAllData
      
        ChDir "C:\Users\Desktop\POSM"
        ActiveWorkbook.SaveAs (Range("D4").Value), _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close

        MsgBox ("Finish")
    End If
End Sub

You will probably figure why it happens if you visit https://stackoverflow.com/q/10714251/11683 and https://stackoverflow.com/q/17733541/11683. — GSerg, Aug 09 '20 at 18:42

score 1 · Answer 1 · answered Aug 09 '20 at 18:54

You keep selecting ranges for no reason and relying on the implicit active sheet that may not necessarily be what you think it is after all those selects.

You don't need to do any of that:

Dim w As Worksheet
Dim w_copy As Worksheet

For Each w In ThisWorkbook.Worksheets
  If w.Range("G4").Value > 0 Then
    
    w.Copy
    Set w_copy = ActiveSheet
    
    With w_copy
      .Range("B12:L22").AutoFilter Field:=1, Criteria1:="="
      .Range(.Range("C15"), .Range("C15").End(xlDown)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
      .ShowAllData
      
      .Parent.SaveAs "C:\Users\Desktop\POSM\" & .Range("D4").Value, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
      .Parent.Close False
    End With
    
  End If
Next

copy multiple sheet if cell()>0

1 Answers1