Posts by jaslake

Option Explicit
Sub Extract_7_Columns()
   Dim sWB          As Workbook
   Dim tWB          As Workbook
   Dim sWS          As Worksheet
   Dim tWS          As Worksheet
   Dim sLR          As Long
   Dim tLR          As Long
   Dim Filter       As String
   Dim Title        As String
   Dim FilterIndex  As Integer
   Dim Filename     As Variant
   Dim MyPath       As String
   Dim ColHeaders   As Range
   Dim Area         As Range
   Application.ScreenUpdating = False
   MyPath = ThisWorkbook.Path
   Filter = "Excel Files (*.xls*),*.xls*," & _
            "Text Files (*.txt),*.txt," & _
            "All Files (*.*),*.*"
   FilterIndex = 1
   MsgBox "Select Source File"   'Master File
   Title = "Select Source File"
   ChDir MyPath & "\"
   With Application
      Filename = .GetOpenFilename(Filter, FilterIndex, Title)
   End With
   If Filename = False Then
      MsgBox "No file was selected."
      Exit Sub
   End If
   Workbooks.Open Filename
   Set sWB = ActiveWorkbook
   Set sWS = sWB.Sheets(1)
   With sWS
      Set ColHeaders = .Range("A1:G1")
   End With
   MsgBox "Select Target File"   'PROCESSING SHEET_1.xlsx
   Title = "Select Target File"
   With Application
      Filename = .GetOpenFilename(Filter, FilterIndex, Title)
   End With
   If Filename = False Then
      MsgBox "No file was selected."
      sWB.Close False
      Exit Sub
   End If
   Workbooks.Open Filename
   Set tWB = ActiveWorkbook
   Set tWS = tWB.Sheets(1)
   With tWS
      .Cells.Clear
      .Range("A1").Value = "REFRENCE SHEET"
      .Range("B1").Resize(1, 7).Value = ColHeaders.Value
   End With
   For Each sWS In sWB.Worksheets
      With sWS
         If Not .Range("A2").Value = "" Then
            sLR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious).Row
            .Range(.Cells(2, 1), .Cells(sLR, 7)).Copy
            With tWS
               tLR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                                 SearchDirection:=xlPrevious).Row + 1
               .Range("A" & tLR).Value = sWS.Name
               .Range("B" & tLR).PasteSpecial
               Application.CutCopyMode = False
            End With
         End If
      End With
   Next sWS
   With tWS
      .Activate
      .Columns(1).Select
      On Error Resume Next
      tLR = .Cells.Find(What:="*", SearchOrder:=xlRows, _
                        SearchDirection:=xlPrevious, _
                        LookIn:=xlFormulas).Row
      For Each Area In ActiveCell.EntireColumn(1).Resize(tLR). _
          SpecialCells(xlCellTypeBlanks).Areas
         Area.Value = Area(1).Offset(-1).Value
      Next
   End With
   sWB.Close False
   tWB.Close True
   Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim ws           As Worksheet
   Dim ws1          As Worksheet
   Dim myCol        As Long
   Dim LR           As Long
   Dim LR1          As Long
   Dim LC           As Long
   Dim LC1          As Long
   Dim x            As Long
   Dim Rng          As Range
   Dim Rng1         As Range
   Dim Rng2         As Range
   Set ws1 = ActiveSheet
   Set ws = Sheets("Sheet1")
   If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   If Target.Address = "$C$6" Then
      With ws1
         LR1 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                           SearchDirection:=xlPrevious).Row
         If LR1 = 9 Then LR1 = 10
         LC1 = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                           SearchDirection:=xlPrevious).Column
         .Range(.Cells(10, "A"), .Cells(LR1, LC1)).ClearContents
      End With
      With ws
         LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious).Row
         LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious).Column
         myCol = WorksheetFunction.Match(Target.Value, .Rows("2:2"), 0)
         If Not .AutoFilterMode Then
            .Rows("2:2").AutoFilter
         End If
         .Range(.Cells(2, 1), .Cells(LR, LC)).AutoFilter field:=myCol, Criteria1:="<>"
         Set Rng1 = .Range(.Cells(3, 1), .Cells(LR, "H"))
         Set Rng2 = .Range(.Cells(3, myCol), .Cells(LR, myCol))
         x = Rng2.Offset(-1, 0).SpecialCells(xlCellTypeVisible).Count
         If x > 1 Then
            Set Rng = Union(Rng1, Rng2)
            Rng.SpecialCells(xlCellTypeVisible).Copy
            ws1.Range("A10").PasteSpecial
         Else
            MsgBox "No Records Found for " & Target.Value
         End If
         .Application.CutCopyMode = False
         .AutoFilterMode = False
      End With
      Application.EnableEvents = True
      Application.ScreenUpdating = True
   End If
End Sub

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim ws           As Worksheet
   Dim ws1          As Worksheet
   Dim myCol        As Long
   Dim LR           As Long
   Dim LR1          As Long
   Dim LC           As Long
   Dim LC1          As Long
   Dim Rng          As Range
   Dim Rng1         As Range
   Dim Rng2         As Range
   Set ws1 = ActiveSheet
   Set ws = Sheets("Sheet1")
   If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   If Target.Address = "$C$6" Then
      With ws1
         LR1 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                           SearchDirection:=xlPrevious).Row
         If LR1 = 9 Then LR1 = 10
         LC1 = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                           SearchDirection:=xlPrevious).Column
         .Range(.Cells(10, "A"), .Cells(LR1, LC1)).ClearContents
      End With
      With ws
         LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious).Row
         LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious).Column
         myCol = WorksheetFunction.Match(Target.Value, .Rows("2:2"), 0)
         If Not .AutoFilterMode Then
            .Rows("2:2").AutoFilter
         End If
         .Range(.Cells(2, 1), .Cells(LR, LC)).AutoFilter field:=myCol, Criteria1:="<>"
         Set Rng1 = .Range(.Cells(3, 1), .Cells(LR, "H"))
         Set Rng2 = .Range(.Cells(3, myCol), .Cells(LR, myCol))
         Set Rng = Union(Rng1, Rng2)
         Rng.SpecialCells(xlCellTypeVisible).Copy
         ws1.Range("A10").PasteSpecial
         .Application.CutCopyMode = False
         .AutoFilterMode = False
      End With
      Application.EnableEvents = True
      Application.ScreenUpdating = True
   End If
End Sub

Option Explicit


Sub Transfer_Master_to_Sheets()




   Dim lastrow As Long, nextrow As Long, c As Range, strName As String, ws As Worksheet
   Dim x            As Long
   Dim rng          As Range




   Application.ScreenUpdating = False




   With Sheet1   'code name for master sheet
      .Range("AU2").Value = "Posted"
      '// determine the last data row using column-E Company Name
      lastrow = .Cells(Rows.Count, "g").End(xlUp).Row




      '// turn of any existing filter
      .AutoFilterMode = False




      '// clear the paste range to receive unique list of company names in subsequent filter action
      .Range("At2").EntireColumn.ClearContents
      .Range("i2:i" & lastrow).AdvancedFilter action:=xlFilterCopy, copytorange:=.Range("at2"), Unique:=True
      .AutoFilterMode = False




      On Error Resume Next




      '// loop through the list of unique company names and pass each value in turn to subsequent filters and copy data to company sheet
      For Each c In .Range("at3:at" & .Cells(Rows.Count, "at").End(xlUp).Row)
         strName = c.Value




         Set ws = Sheets(strName)




         '// Test to see that a sheet for the company name exist before attempting to copy data
         If ws Is Nothing Then   'company sheet does not exist, create new sheet
            With ThisWorkbook
               .Worksheets.Add(after:=Sheets(Sheets.Count)).Name = strName
            End With
         End If
         '// define the next available empty row on the target company sheet
         nextrow = Worksheets(strName).Cells(Rows.Count, "A").End(xlUp).Row + 1




         '// apply the autofilter and copy visible cells
         .Range("$G$2:$AU" & lastrow).AutoFilter Field:=3, Criteria1:=strName
         .Range("$G$2:$AU" & lastrow).AutoFilter Field:=41, Criteria1:="="




         'Count Visible Cells in Column I
         Set rng = .AutoFilter.Range
         x = rng.Columns(3).SpecialCells(xlCellTypeVisible).Count - 1   'Column I
         If x >= 1 Then
            If nextrow = 2 Then
               .Range("g2:ao" & lastrow).Offset(0, 0).SpecialCells(xlCellTypeVisible).Copy
            Else
               .Range("g3:ao" & lastrow).Offset(0, 0).SpecialCells(xlCellTypeVisible).Copy
            End If




            '// paste as value to the target company sheet
            With Worksheets(strName)
               .Range("A" & nextrow).PasteSpecial xlPasteValuesAndNumberFormats




            End With
            .Range("AU3:AU" & lastrow).SpecialCells(xlCellTypeVisible).Value = "x"
            Application.CutCopyMode = False




            Set ws = Nothing
         End If
      Next c
      .AutoFilterMode = False
   End With
   Application.ScreenUpdating = True
End Sub




[COLOR=#333333][COLOR=#333333][/COLOR][/COLOR]

Option Explicit
Sub Print_all()
   Dim ws           As Worksheet
   Dim LR           As Long
   Dim LC           As Long
   Dim cel          As Range
   Set ws = Sheets("Sheet1")
   ActiveWorkbook.Names.Add Name:="Names", RefersTo:= _
                            "=OFFSET(Sheet2!$U$2,0,0,(COUNTA(Sheet2!$U:$U)),1)"
   With ws
      For Each cel In Range("Names")
         .Range("A2").Value = cel.Value
         LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
             SearchDirection:=xlPrevious).Row
         LC = .Range("B5").End(xlToRight).Column
         
         With .PageSetup
                        .PrintArea = ""
                        .PrintArea = Range(Cells(1, 1), Cells(LR, LC)).Address
                        .Orientation = xlPortrait
                        .FitToPagesWide = 1
                        .FitToPagesTall = 1
                    End With
      .PrintPreview
'      .PrintOut
      Next cel
   End With
End Sub

Option Explicit
Sub Print_all()
   Dim ws           As Worksheet
   Dim LR           As Long
   Dim LC           As Long
   Dim cel          As Range
   Set ws = Sheets("Sheet1")
   ActiveWorkbook.Names.Add Name:="Names", RefersTo:= _
                            "=OFFSET(Sheet1!$U$2,0,0,(COUNTA(Sheet1!$U:$U)),1)"
   With ws
      For Each cel In Range("Names")
         .Range("A2").Value = cel.Value
         LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
             SearchDirection:=xlPrevious).Row
         LC = .Range("B5").End(xlToRight).Column
         
         With .PageSetup
                        .PrintArea = ""
                        .PrintArea = Range(Cells(1, 1), Cells(LR, LC)).Address
                        .Orientation = xlPortrait
                        .FitToPagesWide = 1
                        .FitToPagesTall = 1
                    End With
      .PrintPreview
'      .PrintOut
      Next cel
   End With
End Sub