Make checklist from closed WB's and then save updated C'List data back to source WB

**Lungfish** · 07-16-2011, 04:56 AM

2nd part of the code :

'Macro to find values (FilterValue 1 & 2) in the Job Checklists contained in the folder.

Sub Get_Filter(FileNameInA As Boolean, SourceShName As String, _
               SourceShIndex As Integer, FilterRng As String, FilterField As Integer, _
               FilterValue1 As String, FilterValue2 As String, myReturnedFiles As Variant)
    Dim SourceRange As Range, destrange As Range
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim rnum As Long, CalcMode As Long
    Dim SourceSh As Variant
    Dim rng As Range
    Dim RwCount As Long
    Dim I As Long
    Dim z As Long
    Dim vHdr As Variant
    Dim Counter As Integer

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Add a new workbook with one sheet named "FO To Do List"
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    BaseWks.Name = "FO To Do List"

    'Set start row for the Data
    rnum = 2

    'Check if we use a named sheet or the Sheet index
    If SourceShName = "" Then
        SourceSh = SourceShIndex
    Else
        SourceSh = SourceShName
    End If

    'Loop through all files in the array of found files(myFiles)
    For I = LBound(myReturnedFiles) To UBound(myReturnedFiles)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(myReturnedFiles(I))
        On Error GoTo 0

        If Not mybook Is Nothing Then

            'Set SourceRange and check if it is a valid range
            On Error Resume Next

            With mybook.Sheets(SourceSh)
                Set SourceRange = Application.Intersect(.UsedRange, .Range(FilterRng))
            End With

            If Err.Number > 0 Then
                Err.Clear
                Set SourceRange = Nothing
            Else
                'If SourceRange use all columns then skip this file
                If SourceRange.Columns.Count >= BaseWks.Columns.Count Then
                    Set SourceRange = Nothing
                End If
            End If
            On Error GoTo 0

            If Not SourceRange Is Nothing Then

                'Find the last row in BaseWks
                rnum = RDB_Last(1, BaseWks.Cells) + 1

                With SourceRange.Parent
                    Set rng = Nothing

                    'Firstly, remove the AutoFilter
                    .AutoFilterMode = False

                    'Filter the range on the FilterField column (Weeks to Go)
                    SourceRange.AutoFilter Field:=FilterField, _
                                        Criteria1:=FilterValue1, _
                                        Criteria2:=FilterValue2
                  
                    With .AutoFilter.Range
                        'Check if there are results after you use AutoFilter
                        RwCount = .Columns(1).Cells. _
                                  SpecialCells(xlCellTypeVisible).Cells.Count - 1

                        If RwCount = 0 Then
                            'There is no data, only the header
                        Else
                            'Set a range without the Header row
                            Set rng = .Resize(.Rows.Count + 1, .Columns.Count). _
                                      Offset(1, 0).SpecialCells(xlCellTypeVisible)

                            If FileNameInA = True Then
                                'Copy the range and the file name
                                If rnum + RwCount < BaseWks.Rows.Count Then
                                    BaseWks.Cells(rnum, "A").Resize(RwCount).Value _
                                          = mybook.Name
                                    rng.Copy BaseWks.Cells(rnum, "B")
                                End If
                            Else
                                'Copy the range
                                If rnum + RwCount < BaseWks.Rows.Count Then
                                    rng.Copy BaseWks.Cells(rnum, "A")
                                End If
                            End If
                        End If
                    End With

                    'Remove the AutoFilter
                    .AutoFilterMode = False

                End With
            End If

            'Close the "JOB CHECKLIST *" without saving
            mybook.Close savechanges:=False
        End If

        'Open the next workbook
    Next I

**Lungfish** · 07-16-2011, 04:57 AM

3rd (and Messiest) part of the code :

    'Delete Unwanted Columns from JOB CHECKLIST
    BaseWks.Range("D:D,E:E,F:F,G:G,H:H,L:L,M:M,N:N,O:O,R:R").Select
    BaseWks.Range("R1").Activate
    Selection.Delete Shift:=xlToLeft
  
    'Add Header Row to New Worksheet
    vHdr = Array("WEEKS TO GO", "JOB #", "ADDRESS", "B.TRAP", "R. VALVE", "150 SHAFT", "CUT PATH", _
    "CUT KERB", "PITS", "O. PLATE", "T/ SCREEN", "F.O.", "COMPLETION DATE")
    Rows(1).Insert
    Range("A1").Resize(, UBound(vHdr) + 1).Value = vHdr
    
    'Set the Row Height & Column Width in the new workbook
    BaseWks.Rows("1:24").RowHeight = 300
    BaseWks.Columns("A:A").ColumnWidth = 49.3
    BaseWks.Columns("B:B").ColumnWidth = 49.3
    BaseWks.Columns("C:C").ColumnWidth = 250.1
    BaseWks.Columns("D:L").ColumnWidth = 28.5
    BaseWks.Columns("M:M").ColumnWidth = 110
    
    'Change Font Sizes, Text Centering, Wrap Text in new Workbook
    Range("A:C,M:M").Select
    Range("M1").Activate
    With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection.Font
        .Name = "Calibri"
        .Size = 120
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("D:K").Select
    With Selection.Font
        .Name = "Wingdings 2"
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection.Font
        .Name = "Wingdings 2"
        .Size = 120
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1:M1").Select
    With Selection.Font
        .Size = 48
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
    End With
    Range("D1:K1").Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 48
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    
    'Set Cell Oultlines & Borders on New Sheet
    Range("A1:M24").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThick
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThick
    End With
    
    'Clear Cell Fill from pasted data in new sheet
    BaseWks.Cells.Interior.ColorIndex = 2
    
    'Set Page
    BaseWks.PageSetup.Orientation = xlPortrait
    BaseWks.PageSetup.FitToPagesWide = 1
    BaseWks.PageSetup.FitToPagesTall = 1
    BaseWks.PageSetup.Zoom = False
    
   'Insert Todays Date in Header
    With BaseWks.PageSetup
        .CenterHeader = "&200&D"
    End With
    
    'Shade fill every 2nd row in the current selection
    With BaseWks
    For Counter = 1 To Selection.Rows.Count
        'If the row is an odd number (within the selection)...
        If Counter Mod 2 = 1 Then
            'Set the pattern to xlGray16.
            Selection.Rows(Counter).Interior.Pattern = xlGray16
        End If
    Next
    End With
    
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    
End Sub

Make checklist from closed WB's and then save updated C'List data back to source WB

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Re: Make checklist from closed WB's and then save updated C'List data back to source

SOLVED: Make checklist from closed WB's

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions