Thread: Conditional copy of specific cells to another sheet

Hi Anra

Try this code

Option Explicit
Sub Macro1()
    Dim LR As Long
    Dim ws As Worksheet
    Dim Col As String
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        If Not ws.Name = "Master" Then
            If ws.Name = "Ent App" Then
                Col = "C"
            ElseIf ws.Name = "Ent infr" Then Col = "D"
            ElseIf ws.Name = "Ent Arch" Then Col = "E"
            ElseIf ws.Name = "Ent PMO" Then Col = "F"
            End If
            With Sheets("Master")
                LR = .Range("A" & .Rows.Count).End(xlUp).Row
                .AutoFilterMode = False
                .Range(Col & "1:" & Col & LR).AutoFilter Field:=1, Criteria1:="X"
                .Range("A1:B" & LR).SpecialCells(xlVisible).Copy
                .AutoFilterMode = False
            End With
            Sheets(ws.Name).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                                                     SkipBlanks:=False, Transpose:=False
            Sheets(ws.Name).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                                                     False, Transpose:=False
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

Let me know of issues.

John

Hi Anra

Yes please. Let me know how it goes.

John

Hi Anra

A couple of things. I've no idea what this is

a ppt

Secondly, if I understand you correctly, you wish to filter the data for "Ent App" to it's worksheet as the code does now. Then you wish to create a new workbook called "Some Thing" that will have a worksheet in it called "Ent App". This new "Ent App" worksheet will contain the same data as the original copy of "Ent App". Is my understanding correct?

John

Hi Anra

I think this code does as you requested

Option Explicit
Dim ws As Worksheet
Sub Macro1()
    Dim LR As Long
 
    Dim Col As String
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        If Not ws.Name = "Master" Then
            If ws.Name = "Ent App" Then
                Col = "C"
            ElseIf ws.Name = "Ent infr" Then Col = "D"
            ElseIf ws.Name = "Ent Arch" Then Col = "E"
            ElseIf ws.Name = "Ent PMO" Then Col = "F"
            End If
            With Sheets("Master")
                LR = .Range("A" & .Rows.Count).End(xlUp).Row
                .AutoFilterMode = False
                .Range(Col & "1:" & Col & LR).AutoFilter Field:=1, Criteria1:="X"
                .Range("A1:B" & LR).SpecialCells(xlVisible).Copy
                .AutoFilterMode = False
            End With
            Sheets(ws.Name).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                                                     SkipBlanks:=False, Transpose:=False
            Sheets(ws.Name).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                                                     False, Transpose:=False
        Call AddBook
        End If
 
    Next ws
    Application.ScreenUpdating = True
End Sub
 
 
Sub AddBook()
Dim bk As Workbook
Dim bk1 As Workbook
Set bk = ThisWorkbook
Set bk1 = Workbooks.Add()
Application.DisplayAlerts = False
bk1.SaveAs bk.Path & "\" & ws.Name & ".xls", FileFormat:=xlExcel8
ActiveSheet.Name = ws.Name
bk.Worksheets(ws.Name).Cells.Copy
bk1.Worksheets(ws.Name).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                                                     SkipBlanks:=False, Transpose:=False
bk1.Worksheets(ws.Name).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                                                     False, Transpose:=False
Application.DisplayAlerts = True
bk1.Close savechanges:=True
'bk.Activate
End Sub

Please note there are two procedures here and they should both go in the same module. Also note that I've changed the previous code slightly so you'll need to replace it also. The code is in the attached.

Let me know of issues.

John

Hi Anra

Glad it works for you.

Regarding this

Some Files created are large with many rows..would it be possible to add some condition
to say that when the row count in the newly created file exceeds say 50 (testing purposes) to create
a new file which has header row + rows that are greater than 50...

Are you saying that if in a new file to be created, the Row Count is going to be more that 50, then create a second file and split the file into two files? If this is the case, submit a file that exceeds row count of 50 to give me a file to test against.

John

Hi Anra

I'm traveling this weekend and next week. I'll have some but not much spare time. I'll look at this possibility for you. What would the second Ent App file be called...perhaps Ent App 1?

John

Hi Anra

Sorry I haven't gotten back to you. I've been working with my son, daughter-in-law and two grandsons with their new home. Been working 10 hour days and haven't had the clarity of mind to work on your solution.

Going home on Thursday and will address your issue this weekend.

John