Macro for auto filter & Copy to new workbook

Hi..

This will do it..

You need to change the file path to suit you.. (change C:\Departments\ to where you have the files on your PC)

Private Sub CommandButton1_Click()
Dim Crit1 As String
Dim LastRow As Long, LastRow2 As Long, i As Long
Dim myRange

Application.DisplayAlerts = False
Application.ScreenUpdating = False
LastRow = Sheets("Dept").Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow
Crit1 = Sheets("Dept").Cells(i, 1).Value
Sheets("Data").Range("A1:C" & LastRow).AutoFilter Field:=1, Criteria1:=Crit1
Application.Workbooks.Open ("C:\Departments\" & Crit1 & ".xlsx")
LastRow2 = Workbooks(Crit1 & ".xlsx").Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Set myRange = Workbooks("Dept queries.xlsm").Sheets("Data").Range("A2:C" & Workbooks("Dept queries.xlsm").Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible)

myRange.Copy Destination:=Workbooks(Crit1 & ".xlsx").Sheets("Sheet1").Cells(LastRow2 + 1, 1)
Workbooks(Crit1 & ".xlsx").Close SaveChanges:=True

Next i
If Sheets("Data").AutoFilterMode Then Sheets("Data").AutoFilterMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data Has Been Copied!"
End Sub

Hi.... APO....

One more help on this code, copy destination ensure that the previous details should be deleted before pasting the new values.

Thank you for your immediate help....

Originally Posted by apo

Hi..

This will do it..

You need to change the file path to suit you.. (change C:\Departments\ to where you have the files on your PC)

Private Sub CommandButton1_Click()
Dim Crit1 As String
Dim LastRow As Long, LastRow2 As Long, i As Long
Dim myRange

Application.DisplayAlerts = False
Application.ScreenUpdating = False
LastRow = Sheets("Dept").Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow
Crit1 = Sheets("Dept").Cells(i, 1).Value
Sheets("Data").Range("A1:C" & LastRow).AutoFilter Field:=1, Criteria1:=Crit1
Application.Workbooks.Open ("C:\Departments\" & Crit1 & ".xlsx")
LastRow2 = Workbooks(Crit1 & ".xlsx").Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Set myRange = Workbooks("Dept queries.xlsm").Sheets("Data").Range("A2:C" & Workbooks("Dept queries.xlsm").Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible)

myRange.Copy Destination:=Workbooks(Crit1 & ".xlsx").Sheets("Sheet1").Cells(LastRow2 + 1, 1)
Workbooks(Crit1 & ".xlsx").Close SaveChanges:=True

Next i
If Sheets("Data").AutoFilterMode Then Sheets("Data").AutoFilterMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data Has Been Copied!"
End Sub

Hi..

One more help on this code, copy destination ensure that the previous details should be deleted before pasting the new values.

Currently, it appends the data to the next available row..

If you want to clear the data on each sheet before adding fresh data..

After this line:

Application.Workbooks.Open ("C:\Departments\" & Crit1 & ".xlsx")

Add this..

Workbooks(Crit1 & ".xlsx").Sheets("Sheet1").UsedRange.ClearContents

[SOLVED]Thank you every one for your quick help on this.... this is really motivating me to learn things faster

Hi APO.....
After using the macro multiple times found that, it would be very helpful if the macro read the path from the cell value on list tab. Cell.value"F4"

Hi..

How about Browsing for the Folder using a Browse Dialogue...

Private Sub CommandButton1_Click()
Dim Crit1 As String, myFolder As String
Dim LastRow As Long, LastRow2 As Long, i As Long
Dim myRange

Application.DisplayAlerts = False
Application.ScreenUpdating = False
LastRow = Sheets("Dept").Range("A" & Rows.Count).End(xlUp).Row
Continue:
With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    If (.SelectedItems.Count = 0) Then Exit Sub
    myFolder = .SelectedItems(1)
End With

For i = 2 To LastRow
Crit1 = Sheets("Dept").Cells(i, 1).Value
Sheets("Data").Range("A1:C" & LastRow).AutoFilter Field:=1, Criteria1:=Crit1
On Error GoTo ErrHand
Application.Workbooks.Open (myFolder & "\" & Crit1 & ".xlsx")
Workbooks(Crit1 & ".xlsx").Sheets("Sheet1").UsedRange.ClearContents
LastRow2 = Workbooks(Crit1 & ".xlsx").Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Set myRange = Workbooks("Dept queries.xlsm").Sheets("Data").Range("A2:C" & Workbooks("Dept queries.xlsm").Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible)

myRange.Copy Destination:=Workbooks(Crit1 & ".xlsx").Sheets("Sheet1").Cells(LastRow2 + 1, 1)
Workbooks(Crit1 & ".xlsx").Close SaveChanges:=True

Next i
If Sheets("Data").AutoFilterMode Then Sheets("Data").AutoFilterMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Sheets("Dept").Cells(4, 6).Value = myFolder
MsgBox "Data Has Been Copied!"

ErrHand:
    Select Case Err.Number
    Case 1004
        msg = "Error: " & Err.Number & vbCrLf & Err.Description
        MsgBox msg, vbOKOnly, "Incorrect Folder Selected"
        Err.Clear
        GoTo Continue
        Resume Next
    End Select
End Sub

Note: It will also store the most recent folder selection in your Dept sheet..

Thanks a lot..... APO.... This was really helpful.....