Thread: Conditional copy of specific cells to another sheet

Hi Anra

I've had this issue sorta surrounded several times. Still trying to nail down the problem of adding data to more that two sheets. Haven't given up as yet. Still working on it.

John

Hi Anra

I've about gotten this sorted out. I have company this weekend but I'll try to post something late tomorrow or early Monday.

John

Hi Anra

This code is included in the attached workbook. It appears to do as you requested.

Option Explicit
Dim ws As Worksheet
Dim NoShts As Long
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
        Sheets("Master").AutoFilterMode = False
    Next ws
    Application.ScreenUpdating = True
End Sub

and

Sub AddBook()
    Dim LR As Long
    Dim i As Long
    Dim bk As Workbook
    Dim bk1 As Workbook
    Dim x As Long
    Dim vCnt As Long
    Dim Rng As Range
    Dim vCell As Range
    Dim z As String
    Set bk = ThisWorkbook
    LR = bk.Worksheets(ws.Name).Range("A" & Rows.Count).End(xlUp).Row
    x = bk.Worksheets(ws.Name).Range("A2:A" & LR).Count
    NoShts = WorksheetFunction.Ceiling(x / 50, 1)
    For i = 1 To NoShts
        Set bk1 = Workbooks.Add()
        Application.DisplayAlerts = False
        bk1.SaveAs bk.Path & "\" & ws.Name & i & ".xls", FileFormat:=xlExcel8
        Application.DisplayAlerts = True
        ActiveSheet.Name = ws.Name & i
        ActiveSheet.Range("A1:B1").Value = bk.Worksheets("Master").Range("Headings").Value
        ActiveSheet.Range("A1:B1").Font.FontStyle = "Bold"
        vCnt = bk.Worksheets(ws.Name).Range("A2:A" & LR).SpecialCells(xlCellTypeVisible).Count
        If vCnt <= 50 Then
            Set Rng = bk.Worksheets(ws.Name).Range("A2:A" & LR).SpecialCells(xlCellTypeVisible)
            With Rng
                For Each vCell In Rng
                    If vCell.EntireRow.Hidden = False Then
                        Exit For
                    End If
                Next vCell
            End With
            bk.Worksheets(ws.Name).Range(vCell.Address & ":B" & LR).SpecialCells(xlCellTypeVisible).Copy
            bk1.Worksheets(ws.Name & i).Range("A1").Offset(1, 0).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                                                                              SkipBlanks:=False, Transpose:=False
            bk1.Worksheets(ws.Name & i).Range("A2").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                                                                 False, Transpose:=False
            bk1.Close savechanges:=True
        Else
            If vCnt > 50 Then
                Set Rng = bk.Worksheets(ws.Name).Range("A2:A" & LR).SpecialCells(xlCellTypeVisible)
                With Rng
                    For Each vCell In Rng
                        If vCell.EntireRow.Hidden = False Then
                            z = vCell.Row
                            Exit For
                        End If
                    Next vCell
                End With
                bk.Worksheets(ws.Name).Range(vCell.Address & ":B" & z + 49).SpecialCells(xlCellTypeVisible).Copy
                bk.Worksheets(ws.Name).Range(vCell.Address & ":B" & z + 49).EntireRow.Hidden = True
                bk1.Worksheets(ws.Name & i).Range("A2").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                                                                     SkipBlanks:=False, Transpose:=False
                bk1.Worksheets(ws.Name & i).Range("A2").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                                                                     False, Transpose:=False
            End If
            bk1.Close savechanges:=True
        End If
    Next i
    bk.Worksheets(ws.Name).Cells.EntireRow.Hidden = False
End Sub

I don't believe I've changed the first procedure but I won't guarantee it. The second procedure has been changed to accommodate this

if there are 140 rows for example..would like it to create 3 files Ent App1( 50 rows ) Ent App2 ( 50 rows) Ent App3 ( 40 rows)

Try it and see if it does as you require. You can modify the procedure quite easily to do more or less than 50 rows. Simply change the 50's to "Whatever" and the 49's to one less that "Whatever".

Let me know of issues.

John

Hi Anra

It has been a while. I've trashed your folder so will need to work with the file attached to your thread.

1. The worksheet runs fine on my machine. What error message are you getting?

2. I'm color blind but my headings don't appear to have colors

Please do this. Upload the file you're using (with appropriate colors) and with the code. I'll take a look at it.

John

Hi Anra

I've tested the code in Excel 2000 and Excel 2007 and I can't get this line of code to throw an error

LR = bk.Worksheets(ws.Name).Range("A" & Rows.Count).End(xlUp).Row

What is the error message you're getting?

John

Hi Anra

I've tested the attached quite thoroughly in Excel 2000 and 2007. I've not been able to duplicate the error you mentioned. If you still get the error, I'll need to know what the error message says.

I've added this line of code

Const Lines As Long = 20

If you wish to change the number of lies in each file, change it here.

I'll also point out, you need to run the Update procedure first. This procedure calls AddBook.

Let me know of issues.

John