Filter data from one sheet to 14 existing sheets in different workbooks

Hi,
I have a workbook containing information about different student from different classes and sections.
Column B and C are for Class and section respectively.
Data to be copied is from column D to column Y. Row on is for headers.
I need a VBA Code or Macro to copy student information to an existing sheets in different workbooks.

Each workbook is named using class name and section (ex. (grade Seven A"), Name of sheet is "Marks" for all workbooks.
Any ideas?

Note:
New filtered data will replace the old data in the range C4:X64

Khalil

Based on your information regarding the data layout I would suggest a macro using autofilter.

Macro starts by filtering "Master" file using "class" and "section" as filters. The filtered result should be copied.

The "right" target workbook should be opened, old data deleted and the new data pasted to it.

The target workbook is then saved and closed.

Macro loops, sets new autofilter, copies, opens new target workbook .....

I assume that all target workbooks are placed in the same folder so a macro like that should not be too difficult to write. The only thing I'm unsure about is seeing you location is Israel so I think you read and write "right to left" whereas most European read and write "left to right" and I guess your worksheets in an excel workbook is placed according to the "right to left" rule.

Alf

Thanks Alf,
Yes, my Excel sheet are from right-to-left but the names of columns and rows are the same, they do not change;
They are exactly as if you European.
My issue is that I do not know how to write the code or command lines for macros.
Is it possible that the macros opens the workbooks and delete the old data in the specific range?

Khalil

Thanks Alf,
I do understand the logic and some of the lines in the code.
The code does not include the "Filtering" part in the "Master" worksheet for "Class" and "Section".
How is it done?
Can you help please?
Khalil

The code does not include the "Filtering" part in the "Master" worksheet for "Class" and "Section".

That is because I don't know the layout of the data in the master file. Setting a filer for "Class" and "Section" one could use somthing like this:

With ActiveSheet
     .UsedRange.AutoFilter
     .UsedRange.AutoFilter field:=2, Criteria1:="Class1"
     .UsedRange.AutoFilter field:=3, Criteria1:="Section1"
    End With

where the field is a rellative column address based on where your data starts. If it starts in column A then column B is field 2 and c is field 3. But if data starts in column B and filtering should be done in column B and C then field address becomes 1 and 2.

In order to help you with this code I suggest you upload a file with all class and section names and the general data that is in the master file, then on a sheet show how you wish to filter data and finaly I need to know the file name structure so when filtering is done the right file is opened and the data copied to it.

Don't forget to remove all sensitive data from the file before uploading.

Alf

Hi Alf,
Attached is the master file with sample artificial data named "AllStudentsMaster.xlsx",
and one of the target files named "Grade 7 B.xlsm"
I hope this will help.
Thanks
Khalil

Perhaps something like this?

Option Explicit

Sub ExtrData()
Dim cell As Range
Dim i As Integer
Dim sFile As String
Dim sPath As String
Dim wb As Workbook

sPath = "C:\MyFiles\"

Application.ScreenUpdating = False
i = 2

Sheets("Sheet1").Activate

For Each cell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)

If cell & cell.Offset(0, 1) = cell.Offset(1, 0) & cell.Offset(1, 1) Then
    Else
        Range(cell, cell.Offset(0, 1)).Copy
       Sheet2.Range("B" & i).PasteSpecial xlPasteValues
       Application.CutCopyMode = False
       i = i + 1
End If

Next

Sheets("Sheet2").Activate

For Each cell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)

cell.Offset(0, 2) = cell & " " & cell.Offset(0, 1) & ".xlsm"

Next

Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).Name = "Info"

Application.ScreenUpdating = True

Sheets("Sheet1").Activate

For Each cell In Range("Info")
 
sFile = cell.Offset(0, 2)

With ActiveSheet
    .AutoFilterMode = False
    .UsedRange.AutoFilter
    .UsedRange.AutoFilter field:=2, Criteria1:=cell
    .UsedRange.AutoFilter field:=3, Criteria1:=cell.Offset(0, 1)
End With

ActiveSheet.AutoFilter.Range.Offset(1, 5).Copy

Set wb = Workbooks.Open(sPath & sFile)
         
 wb.Close SaveChanges:=True

 Sheets("Marks").Activate
       
 Range("E14:X64").ClearContents

 Range("E14").PasteSpecial xlPasteAll
 
  wb.Close SaveChanges:=True

  ThisWorkbook.Activate

Next

Sheets("Sheet2").Activate

ActiveSheet.UsedRange.ClearContents

ActiveWorkbook.Names("Info").Delete

Sheets("Sheet1").Activate

ActiveSheet.UsedRange.AutoFilter

Application.ScreenUpdating = False

End Sub

First of all make a copy of all you original files and put them in a special folder for you to test this macro on!!!!

So you need to change the string "sPath" to suit your needs.

Macro starts by looping through all values in column B sheet1, it compaires the value B2:C2 to the value B3:C3, if these are equal then macro just tests net pair of values. When B3:C3 are compaired to B4:C4 these are differnt (C3 is different to C4) so the values B3:C3 gets copied to sheet2. After all different values are found sheet2 gets activated and macro adds values from B column with C colum and add the ".xlsm" exstention in the D column in order to build a string. The first one being "Grade 7 B.xlsm" So based on data in B and C column all file names are build.

Then a range name "Info" is created, sheet1 activated and an autofiter set up with value from column B as first criteria and C as second. The filterd result is copied. The Offset setting should copy from 1 row below heading and 5 rows to left i.e. column E. This is based on your comments that the files to update should first get rid of old data range E4:X64. But looking at the "Grade 7 B.xlsm" file it seems to me that data starts at column E row 14??

After opening the workbook and sheet "Marks" gets activated, macro clears range E14:X64 and pastes in the new data to range E14 and saves and closes workbook. Then "Thisworkbook" (i.e. "AllStudentsMaster") get activated and the next values in "Info" range gets fed into the autofilter, the nex file opened and so forth...

Having gone through all data in "Info" sheet2 gets activated, data cleared and range name "Info" deleted, sheet1 activated and original autofilter setting reset.

Alf

Hi Alf,

thanks for the code,
I think it needs to be adjusted.
Below is the code with some notes when it was executed.

Option Explicit

Sub ExtrData()
Dim cell As Range
Dim i As Integer
Dim sFile As String
Dim sPath As String
Dim wb As Workbook

sPath = "C:\Stony\"

Application.ScreenUpdating = False
i = 2

Sheets("Sheet1").Activate

For Each cell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)

If cell & cell.Offset(0, 1) = cell.Offset(1, 0) & cell.Offset(1, 1) Then
Else
Range(cell, cell.Offset(0, 1)).Copy
Sheet2.Range("B" & i).PasteSpecial xlPasteValues
Application.CutCopyMode = False
i = i + 1
End If

Next

Sheets("Sheet2").Activate

For Each cell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)

cell.Offset(0, 2) = cell & " " & cell.Offset(0, 1) & ".xlsm"

Next

Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).Name = "Info"

Application.ScreenUpdating = True

Sheets("Sheet1").Activate

For Each cell In Range("Info")
sFile = cell.Offset(0, 2)

With ActiveSheet
.AutoFilterMode = False
.UsedRange.AutoFilter
.UsedRange.AutoFilter field:=2, Criteria1:=cell
.UsedRange.AutoFilter field:=3, Criteria1:=cell.Offset(0, 1)
End With

ActiveSheet.AutoFilter.Range.Offset(1, 3).Copy

Set wb = Workbooks.Open(sPath & sFile)

wb.Close SaveChanges:=True ' After running this line,
' I will get a Run-Time error 9
' Subsript out of Range
' and the following line: Sheets("Marks").Activate is in Yellow. and Grade 7 B.xlsm is not open, and the range to copy is still selected.

' I added an apostrophie to the line (wb.Close SaveChanges:=True) to make it a remark
' The code continued and opened the Grade 7 B.xlsm and it:
' 1- deleted the range C14:X64
' 2- gave an error message that it could not - paste special - the values.
' the sheet "Marks" is protected sheet using password 112. When I unprotect the sheet,
' it also gave the same error not being able to paste special the values.


Sheets("Marks").Activate

Range("C14:X64").ClearContents

Range("C14").PasteSpecial xlPasteAll

wb.Close SaveChanges:=True

ThisWorkbook.Activate

Next

Sheets("Sheet2").Activate

ActiveSheet.UsedRange.ClearContents

ActiveWorkbook.Names("Info").Delete

Sheets("Sheet1").Activate

ActiveSheet.UsedRange.AutoFilter

Application.ScreenUpdating = False

End Sub

Have a go at this modefication and hopefully this will work better.

Yes you were right it was one "wb.Close" too many, I've also set a new range name "data". The advantage with this is that after filtering you just get the filtered values you wish for so if for instance you wish to include "ceeluer" you will have to replace X with Y as the Y column is not oncluded in the present setup for the "data" range.

In the "PasteSpecial" command to the target file I have used the "xlPasteAll", could be that it is better to use the "xlPasteValues".

If you still have problems with this code I would suggest you select the "Step through" option for this macro and press the F8 button to work you way through the macro and check what happends with the "MasterAllStudents" and one "Grade" file.

Option Explicit

Sub ExtrData()
Dim cell As Range
Dim i As Integer
Dim sFile As String
Dim sPath As String
Dim wb As Workbook

sPath = "C:\Stony\"

Application.ScreenUpdating = False
i = 2

Sheets("Sheet1").Activate

Range("C2:X" & Range("B" & Rows.Count).End(xlUp).Row).Name = "data"


For Each cell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)

If cell & cell.Offset(0, 1) = cell.Offset(1, 0) & cell.Offset(1, 1) Then
    Else
        Range(cell, cell.Offset(0, 1)).Copy
       Sheet2.Range("B" & i).PasteSpecial xlPasteValues
       Application.CutCopyMode = False
       i = i + 1
End If

Next

Sheets("Sheet2").Activate

For Each cell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)

cell.Offset(0, 2) = cell & " " & cell.Offset(0, 1) & ".xlsm"

Next

Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).Name = "Info"

Sheets("Sheet1").Activate

For Each cell In Range("Info")
 
sFile = cell.Offset(0, 2)

With ActiveSheet
    .AutoFilterMode = False
    .UsedRange.AutoFilter
    .UsedRange.AutoFilter field:=2, Criteria1:=cell
    .UsedRange.AutoFilter field:=3, Criteria1:=cell.Offset(0, 1)
End With

Set wb = Workbooks.Open(sPath & sFile)
         
 Sheets("Marks").Activate
       
 Range("C14:X64").ClearContents
 
 ThisWorkbook.Activate
 
 Range("data").SpecialCells(xlCellTypeVisible).Copy

 wb.Activate

 Range("C14").PasteSpecial xlPasteAll
 
 wb.Close SaveChanges:=True

  ThisWorkbook.Activate

Next

Sheets("Sheet2").Activate

ActiveSheet.UsedRange.ClearContents

ActiveWorkbook.Names("Info").Delete

Sheets("Sheet1").Activate

ActiveWorkbook.Names("data").Delete

ActiveSheet.UsedRange.AutoFilter

Application.ScreenUpdating = False

End Sub

Alf

Thanks Alf
It works fine.

I included the celular also
Thank again

Not to happy about this part of the code as it really is not checking for duplicates, just checking that a value is not the same as the next one. As you use Excel 2007 one can use Excel's "Remove duplicate" function so get rid of this part of the code

For Each cell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)

If cell & cell.Offset(0, 1) = cell.Offset(1, 0) & cell.Offset(1, 1) Then
    Else
        Range(cell, cell.Offset(0, 1)).Copy
       Sheet2.Range("B" & i).PasteSpecial xlPasteValues
       Application.CutCopyMode = False
       i = i + 1
End If

Next

Sheets("Sheet2").Activate

and replace it with this instead

Range("B2:C" & Range("B" & Rows.Count).End(xlUp).Row).Copy

Sheets("Sheet2").Activate

Range("B2").PasteSpecial xlPasteValues

 Application.CutCopyMode = False
 
ActiveSheet.Range("B2:C" & Range("C" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo

Alf

You are welcome and thanks for feedback.

If this solves you problem don't forget to mark thread "Solved" as per forum rules.

Alf

Ps

To mark your thread solved do the following:
-Go to the top of the first post
-Select Thread Tools
-Select Mark thread as Solved

Thanks again Alf

Khalil