Open excel files based on a list

[myay_87]

Hi,

I'm trying to open multiple xlsx files and updated based on a list from another sheet, with VBA, but I created VBA only for one line from communication matrix and i need it for all lines

Sub Update_regionali()

Dim i As Integer
Dim last_row As Integer

last_row = Application.WorksheetFunction.CountA(Worksheets("Distributie Mail").Range("H:H"))

   For i = 2 To last_row

' Update

    If Worksheets("Distributie Mail").Range("I2") = "OK" Then
        Workbooks.Open ("Z:\Q1\Planificari\Planificari Regionali\Planificare site-uri Alexandru Bria.xlsx")
        Sheets("Planificare").Select
        Rows("2:2").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Delete Shift:=xlUp
        Windows("Planificare Regionali.xlsb").Activate
        Sheets("Planificare").Select
        If Not ActiveSheet.AutoFilterMode Then
                ActiveSheet.Range("A1:Z1").AutoFilter
        End If
        ActiveSheet.Range("$A$1:$Z$21").AutoFilter Field:=29, Criteria1:= _
            "Alexandru Bria"
        Range("A1").Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Windows("Planificare site-uri Alexandru Bria.xlsx").Activate
        Range("A1").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWorkbook.Save
        Columns("A:Z").EntireColumn.AutoFit
        ActiveWorkbook.Save
        ActiveWindow.Close
        Windows("Planificare Regionali.xlsb").Activate
        
    End If


    Windows("Planificare Regionali.xlsb").Activate
    Sheets("Planificare").Select
'        If ActiveSheet.AutoFilterMode = False Then
'             ActiveSheet.ShowAllData
'        End If
    Range("A1").Select
    Sheets("Distributie Mail").Select
    Range("A1").Select
Exit For
Next i
End Sub


my communication matrix

[ATTACH type="full"]54577[/ATTACH]

 

[Siddharth Rout]

Couple of observations

1. When working with Excel rows, avoid declaring the variable as Integer. Declare them as Long. Excel 2007+ has 1048576 rows. If we try to store this value in an integer variable, you will get an Overflow error.
2. Avoid the use of .Select and .Activate. Three main reasons why .Select, .Activate, Selection, Activecell, Activesheet, Activeworkbook, etc. should be avoided
   1. It slows down your code.
   2. It is usually the main cause of runtime errors.
   3. The "active" cell, sheet, workbook may not be the one you think is active. Create proper objects and work with them.
3. CountA should be avoided to determine the last row as it will give you incorrect result if there are blank cells in between.
4. Work with Objects. It will make your code easier to handle and maintain
5. Your autofilter range is "$A$1:$Z$21" and you have set the field number as 29 (Field:=29). Your field cannot be greater than 26 in this case.

Is this what you are trying? (UNTESTED) I have commented the code but if you face any issues then simply let me know which line is giving you the error.

Option Explicit

Sub Update_regionali()
    Dim i As Long
    Dim last_row As Long
    
    Dim wsAThis As Worksheet
    Dim wsBThis As Worksheet
    
    Dim wbNew As Workbook
    Dim wsNew As Worksheet
    
    Dim rngToCopy As Range

    Set wsAThis = ThisWorkbook.Sheets("Distributie Mail")
    Set wsBThis = ThisWorkbook.Sheets("Planificare")
    
    '~~> Filter the range and store it in an object for later use
    With wsBThis.Range("$A$1:$Z$21")
        '~~> Change 29 to the relevant col number. I am using 26 as an example
        .AutoFilter Field:=26, Criteria1:="Alexandru Bria"
    
        Set rngToCopy = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
    End With

    With wsAThis
        '~~> Get last row of column H
        last_row = .Range("H" & .Rows.Count).End(xlUp).Row
        
        '~~> Loop through the file names. I am assuming that the file names
        '~~> are in column H. Chnage as applicable.
        For i = 2 To last_row
            If .Range("I" & i).Value2 = "OK" Then
                '~~> Open the workbook and set your objects
                Set wbNew = Workbooks.Open(.Range("H" & i).Value2)
                Set wsNew = wbNew.Sheets("Planificare")
            
                With wsNew
                    '~~> Delete row 2 onwards
                    .Range("2:" & .Rows.Count).Delete Shift:=xlUp
                    
                    '~~> Now copy the range and paste it
                    rngToCopy.Copy .Rows(1)
                
                    .Columns("A:Z").EntireColumn.AutoFit
                End With
            
                wbNew.Close (True)
                DoEvents
            End If
        Next i
    End With
End Sub

 

[myay_87]

Let me explain what my application is doing

I have one file with my information's where I have sheet "Distributie Mail" and "Planificare" which is called "Planificare Echipe" and several files with the name of my teams from Sheet "Distributie Mail", column B.

Sheet "Planificare" from file "Planificare Echipe" contain all works for my teams Sheet "Distributie Mail" from file "Planificare Echipe" contain the list with my teams

Sheet "Distributie Mail":

1. in column "I", I have a VLOOKUP who is checking in sheet "Planificare" if the team has a work allocated. If it's true, the VLOOKUP it's returning "OK"
2. in column "G" it's the link to the file team.
3. in column "B" it's the name of the team.


My application it supposed to do this:
If, for first team, from Sheet "Distributie Mail", in column it finds "ok", then:
1. open the team file from column "G"
2. it's keeping the first row and delete the rest of the rows 3. it's going in file "Planificare Echipe" sheet "Planificare"
4. it's filtering the table based on the name of the team from Sheet "Distributie Mail" in column "B"
5. it's copy the filtered information and pasted into team file name.
6. it's saving the file and the it's closing

After the application finished the first line from Sheet "Distributie Mail" it's going to next line and if will find "ok" in column "I" will run the code, else will go to the next line

The code that you send it to me it's coping the same information for all my teams

 

[Siddharth Rout]

Yes it is copying the same information because the Autofilter is hardcoded

AutoFilter Field:=26, Criteria1:="Alexandru Bria"

From where are you picking the values (names) for Autofilter?

 

[myay_87]

Yes it is copying the same information because the Autofilter is hardcoded

AutoFilter Field:=26, Criteria1:="Alexandru Bria"

From where are you picking the values (names) for Autofilter?

From Sheet "Distributie Mail" cell b2. you can see the photo that I attached

 

[Siddharth Rout]

One last question. Regarding column 29. You are trying to filter which column in Planificare sheet in the information file? Is it Column G?

 

[myay_87]

Sorry, in my first code I wrote wrong criteria for filtering

I corrected in the VBA code in the Field and Criteria1

.AutoFilter Field:=7, Criteria1:=" RCS Brasov Paicu"

 

[Siddharth Rout]

I have not tested this. Is this what you are trying?

Option Explicit

Sub Update_regionali()
    Dim i As Long
    Dim last_row As Long
    
    Dim wsAThis As Worksheet
    Dim wsBThis As Worksheet
    
    Dim wbNew As Workbook
    Dim wsNew As Worksheet
    
    Dim rngToCopy As Range
    
    Dim NameTobeFiltered As String
    
    Set wsAThis = ThisWorkbook.Sheets("Distributie Mail")
    Set wsBThis = ThisWorkbook.Sheets("Planificare")
    
    With wsAThis
        '~~> Get last row of column H
        last_row = .Range("H" & .Rows.Count).End(xlUp).Row
        
        '~~> Loop through the file names. I am assuming that the file names
        '~~> are in column H. Chnage as applicable.
        For i = 2 To last_row
            If .Range("I" & i).Value2 = "OK" Then
                
                '~~> Get the name to be filtered
                NameTobeFiltered = .Range("B" & i).Value2
                
                '~~> Filter the range and store it in an object for later use
                With wsBThis
                    .AutoFilterMode = False
                    
                    With .Range("$A$1:$Z$21")
                        '~~> Filter Column G (7th column)
                        .AutoFilter Field:=7, Criteria1:=NameTobeFiltered
                
                        Set rngToCopy = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
                    End With
                End With
    
                '~~> Open the workbook and set your objects
                Set wbNew = Workbooks.Open(.Range("H" & i).Value2)
                Set wsNew = wbNew.Sheets("Planificare")
            
                With wsNew
                    '~~> Delete row 2 onwards
                    .Range("2:" & .Rows.Count).Delete Shift:=xlUp
                    
                    '~~> Now copy the range and paste it
                    rngToCopy.Copy .Rows(1)
                
                    .Columns("A:Z").EntireColumn.AutoFit
                End With
            
                wbNew.Close (True)
                DoEvents
            End If
        Next i
    End With
End Sub

 

[myay_87]

It's working.

Thanks

 

[Siddharth Rout]

It's working.

Thanks

Thank you for taking the time out for providing a feedback