Loop Reading Wrong Value

[jalrs]

Hello guys,

I managed to get a code almost working without any assistance, purely based on my former doubts and the assistance I got there. Happens I'm with a small problem, I believe, and I can't seem to work around it.

What the code is intended to do is read values on sheet "Macro1", open those cell value files on a specific location, copy them from sheet "Pendentes" and paste them to sheet "Refresh". It should paste under the last filled row. It's working for the first cell value, but for the second it displays an error saying that file doesn't exist because when it loops it's reading the value from "Refresh" sheet cells, instead of "Macro1" sheet cells.

Here is the code:

Option Explicit
Sub mergingmacro1()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, i As Long
Dim mypath As String, docname As String, filtervalue As String

Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("Refresh")
Set ws3 = wb2.Worksheets("Macro1")

lr1 = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1 'check where is the last filled row on Refresh Sheet, +1 regarding the headers on row 1 i believe
lr2 = ws3.Cells(Rows.Count, "A").End(xlUp).Row 'check where is the last filled row on Macro1 Sheet. Each row equals to one department

ws3.Activate 'activates Macro1 sheet

    For i = 1 To lr2 'first area on row one, so i value equals to 1. loops untill lr2, where last area is found
       
        filtervalue = Cells(i, 1).Value 'filtervalue equals each area name, according to each row on macro1 sheet
       
        Workbooks.Open Filename:=ThisWorkbook.Path & "\Recebidos\ST_" & Cells(i, 1).Value & ".xlsx" 'opens each row area workbook
       
        Set wb3 = Workbooks("ST_" & filtervalue & ".xlsx")
       
        Set ws4 = wb3.Worksheets("Pendentes")
       
        lr3 = ws4.Cells(Rows.Count, "A").End(xlUp).Row 'finds where is the last row filled with data to be able to copy it
       
        With ws2.Range("A2:BC" & lr1) 'because it's where we are going to paste all the data - merge, lr1 here is due to rows being dynamic prior to previous area rows of data, ie, I can have two rows of data for i1, so i2 would start on row 4, if I would have 3 sets of data for i1, i2 would start on row 5. remember headers are on row 1
       
            With ws4 'because it's where we copy the data as individuals - before merging
           
                .Range("A2:BC" & lr3).Copy 'copies data from ws4
                ws2.Cells(lr1, 1).PasteSpecial Paste:=xlPasteValues 'pastes ws4 data as values on ws2, ws2 is the refresh sheet on the merging workbook
               
            End With
           
        End With
       
        Application.CutCopyMode = False
       
    Next i
   
ws2.Activate 'when the loop ends, we activate ws2

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "Atualizar ST" & ".xlsx", FileFormat:=xlOpenXMLWorkbook 'in order to not lose the template, we saveas on the same destination with a new name

ActiveWorkbook.Close 'close the brand new renamed workbook

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Any help is greatly appreciated
Thanks!

 

[Snakehips]

@jalrs
I reckon the Paste Special is negating the active status of ws3.
Try bringing the ws3.Activate inside of the loop.

For i = 1 To lr2 'first area on row one, so i value equals to 1. loops untill lr2, where last area is found
       ws3.Activate 'activates Macro1 sheet

Hope that helps.

 

[jalrs]

@jalrs
I reckon the Paste Special is negating the active status of ws3.
Try bringing the ws3.Activate inside of the loop.

For i = 1 To lr2 'first area on row one, so i value equals to 1. loops untill lr2, where last area is found
       ws3.Activate 'activates Macro1 sheet

Hope that helps.

Hello Snakehips and thank you for your time answering.

Just as you replied I did that and worked too.

Additionally could you provide some help regarding the last filled row? Should be a quick fix. It's not directly to the title, but it's on the description of the whole thing. It is overwritting it instead of pasting below the last row with data.

Thanks

 

[Snakehips]

Glad that helped.
Similar issue regarding the overwriting. You have lr1 established outside of the loop so it only ever equals the initial first available row.
Thus it will overwrite. Bring it into the loop as below.
I also think you have two pretty much redundant 'With' statements. See my edits on the comments. Not worth two with replacing two single simple lines?

Sub mergingmacro1()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, i As Long
Dim mypath As String, docname As String, filtervalue As String

Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("Refresh")
Set ws3 = wb2.Worksheets("Macro1")


lr2 = ws3.Cells(Rows.Count, "A").End(xlUp).Row 'check where is the last filled row on Macro1 Sheet. Each row equals to one department

    For i = 1 To lr2 'first area on row one, so i value equals to 1. loops untill lr2, where last area is found
    
        lr1 = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1 'check where is the last filled row on Refresh Sheet.  *Then +1 then gives next available row Do within loop as it changes after each paste
        
        ws3.Activate 'activates Macro1 sheet
        
        filtervalue = Cells(i, 1).Value 'filtervalue equals each area name, according to each row on macro1 sheet
       
        Workbooks.Open FileName:=ThisWorkbook.Path & "\Recebidos\ST_" & Cells(i, 1).Value & ".xlsx" 'opens each row area workbook
       
        Set wb3 = Workbooks("ST_" & filtervalue & ".xlsx")
       
        Set ws4 = wb3.Worksheets("Pendentes")
       
        lr3 = ws4.Cells(Rows.Count, "A").End(xlUp).Row 'finds where is the last row filled with data to be able to copy down to it
       
        ' *******THIS WITH REDUNDANT ??? '***With ws2.Range("A2:BC" & lr1)   '*** 'because it's where we are going to paste all the data - merge, lr1 here is due to rows being dynamic prior to previous area rows of data, ie,
        'I can have two rows of data for i1, so i2 would start on row 4, if I would have 3 sets of data for i1, i2 would start on row 5. remember headers are on row 1
       
            ' ******  Redundant ????   '*******  'With ws4 'because it's where we copy the data as individuals - before merging
           
                ws4.Range("A2:BC" & lr3).Copy 'copies data from ws4
                ws2.Cells(lr1, 1).PasteSpecial Paste:=xlPasteValues 'pastes ws4 data as values on ws2, ws2 is the refresh sheet on the merging workbook
               
            '**** Redundant ?????   ' End With '*****
           
        '  ******* Redundant ??? ' **End With******
       
        Application.CutCopyMode = False
       
    Next i
   
ws2.Activate 'when the loop ends, we activate ws2

ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "Atualizar ST" & ".xlsx", FileFormat:=xlOpenXMLWorkbook 'in order to not lose the template, we saveas on the same destination with a new name

ActiveWorkbook.Close 'close the brand new renamed workbook

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

 

[jalrs]

Glad that helped.
Similar issue regarding the overwriting. You have lr1 established outside of the loop so it only ever equals the initial first available row.
Thus it will overwrite. Bring it into the loop as below.
I also think you have two pretty much redundant 'With' statements. See my edits on the comments. Not worth two with replacing two single simple lines?

Sub mergingmacro1()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, i As Long
Dim mypath As String, docname As String, filtervalue As String

Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("Refresh")
Set ws3 = wb2.Worksheets("Macro1")


lr2 = ws3.Cells(Rows.Count, "A").End(xlUp).Row 'check where is the last filled row on Macro1 Sheet. Each row equals to one department

    For i = 1 To lr2 'first area on row one, so i value equals to 1. loops untill lr2, where last area is found
   
        lr1 = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1 'check where is the last filled row on Refresh Sheet.  *Then +1 then gives next available row Do within loop as it changes after each paste
       
        ws3.Activate 'activates Macro1 sheet
       
        filtervalue = Cells(i, 1).Value 'filtervalue equals each area name, according to each row on macro1 sheet
      
        Workbooks.Open FileName:=ThisWorkbook.Path & "\Recebidos\ST_" & Cells(i, 1).Value & ".xlsx" 'opens each row area workbook
      
        Set wb3 = Workbooks("ST_" & filtervalue & ".xlsx")
      
        Set ws4 = wb3.Worksheets("Pendentes")
      
        lr3 = ws4.Cells(Rows.Count, "A").End(xlUp).Row 'finds where is the last row filled with data to be able to copy down to it
      
        ' *******THIS WITH REDUNDANT ??? '***With ws2.Range("A2:BC" & lr1)   '*** 'because it's where we are going to paste all the data - merge, lr1 here is due to rows being dynamic prior to previous area rows of data, ie,
        'I can have two rows of data for i1, so i2 would start on row 4, if I would have 3 sets of data for i1, i2 would start on row 5. remember headers are on row 1
      
            ' ******  Redundant ????   '*******  'With ws4 'because it's where we copy the data as individuals - before merging
          
                ws4.Range("A2:BC" & lr3).Copy 'copies data from ws4
                ws2.Cells(lr1, 1).PasteSpecial Paste:=xlPasteValues 'pastes ws4 data as values on ws2, ws2 is the refresh sheet on the merging workbook
              
            '**** Redundant ?????   ' End With '*****
          
        '  ******* Redundant ??? ' **End With******
      
        Application.CutCopyMode = False
      
    Next i
  
ws2.Activate 'when the loop ends, we activate ws2

ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "Atualizar ST" & ".xlsx", FileFormat:=xlOpenXMLWorkbook 'in order to not lose the template, we saveas on the same destination with a new name

ActiveWorkbook.Close 'close the brand new renamed workbook

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Hello again Snakehips,

Right now I'm short on time to review all the aspects you addressed. I will do it tomorrow and get back to you.

Thanks for your time and hope you have a nice weekend!

 

[jalrs]

Glad that helped.
Similar issue regarding the overwriting. You have lr1 established outside of the loop so it only ever equals the initial first available row.
Thus it will overwrite. Bring it into the loop as below.
I also think you have two pretty much redundant 'With' statements. See my edits on the comments. Not worth two with replacing two single simple lines?

Sub mergingmacro1()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, i As Long
Dim mypath As String, docname As String, filtervalue As String

Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("Refresh")
Set ws3 = wb2.Worksheets("Macro1")


lr2 = ws3.Cells(Rows.Count, "A").End(xlUp).Row 'check where is the last filled row on Macro1 Sheet. Each row equals to one department

    For i = 1 To lr2 'first area on row one, so i value equals to 1. loops untill lr2, where last area is found
   
        lr1 = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1 'check where is the last filled row on Refresh Sheet.  *Then +1 then gives next available row Do within loop as it changes after each paste
       
        ws3.Activate 'activates Macro1 sheet
       
        filtervalue = Cells(i, 1).Value 'filtervalue equals each area name, according to each row on macro1 sheet
      
        Workbooks.Open FileName:=ThisWorkbook.Path & "\Recebidos\ST_" & Cells(i, 1).Value & ".xlsx" 'opens each row area workbook
      
        Set wb3 = Workbooks("ST_" & filtervalue & ".xlsx")
      
        Set ws4 = wb3.Worksheets("Pendentes")
      
        lr3 = ws4.Cells(Rows.Count, "A").End(xlUp).Row 'finds where is the last row filled with data to be able to copy down to it
      
        ' *******THIS WITH REDUNDANT ??? '***With ws2.Range("A2:BC" & lr1)   '*** 'because it's where we are going to paste all the data - merge, lr1 here is due to rows being dynamic prior to previous area rows of data, ie,
        'I can have two rows of data for i1, so i2 would start on row 4, if I would have 3 sets of data for i1, i2 would start on row 5. remember headers are on row 1
      
            ' ******  Redundant ????   '*******  'With ws4 'because it's where we copy the data as individuals - before merging
          
                ws4.Range("A2:BC" & lr3).Copy 'copies data from ws4
                ws2.Cells(lr1, 1).PasteSpecial Paste:=xlPasteValues 'pastes ws4 data as values on ws2, ws2 is the refresh sheet on the merging workbook
              
            '**** Redundant ?????   ' End With '*****
          
        '  ******* Redundant ??? ' **End With******
      
        Application.CutCopyMode = False
      
    Next i
  
ws2.Activate 'when the loop ends, we activate ws2

ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "Atualizar ST" & ".xlsx", FileFormat:=xlOpenXMLWorkbook 'in order to not lose the template, we saveas on the same destination with a new name

ActiveWorkbook.Close 'close the brand new renamed workbook

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Hello Snakehips,

I'm very new to VBA, this project was my first touch to it. Therefore, I appreciate any feedback regarding improving the overview of my code. It also prevents sloppy programming, I believe.
I will take that and learn from it. This being said, I will do some cleaning later tonight and hopefully everything will run smoothly like it just did with adding lr1 into the loop like you said.

In case I mess up, I will comeback here and ask for your help, In case I don't, I'll also comeback to thank you once again.
In the meantime I added your post as solution.

Thank you Snakehips!

 

[jalrs]

Glad that helped.
Similar issue regarding the overwriting. You have lr1 established outside of the loop so it only ever equals the initial first available row.
Thus it will overwrite. Bring it into the loop as below.
I also think you have two pretty much redundant 'With' statements. See my edits on the comments. Not worth two with replacing two single simple lines?

Sub mergingmacro1()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, i As Long
Dim mypath As String, docname As String, filtervalue As String

Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("Refresh")
Set ws3 = wb2.Worksheets("Macro1")


lr2 = ws3.Cells(Rows.Count, "A").End(xlUp).Row 'check where is the last filled row on Macro1 Sheet. Each row equals to one department

    For i = 1 To lr2 'first area on row one, so i value equals to 1. loops untill lr2, where last area is found
 
        lr1 = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1 'check where is the last filled row on Refresh Sheet.  *Then +1 then gives next available row Do within loop as it changes after each paste
     
        ws3.Activate 'activates Macro1 sheet
     
        filtervalue = Cells(i, 1).Value 'filtervalue equals each area name, according to each row on macro1 sheet
    
        Workbooks.Open FileName:=ThisWorkbook.Path & "\Recebidos\ST_" & Cells(i, 1).Value & ".xlsx" 'opens each row area workbook
    
        Set wb3 = Workbooks("ST_" & filtervalue & ".xlsx")
    
        Set ws4 = wb3.Worksheets("Pendentes")
    
        lr3 = ws4.Cells(Rows.Count, "A").End(xlUp).Row 'finds where is the last row filled with data to be able to copy down to it
    
        ' *******THIS WITH REDUNDANT ??? '***With ws2.Range("A2:BC" & lr1)   '*** 'because it's where we are going to paste all the data - merge, lr1 here is due to rows being dynamic prior to previous area rows of data, ie,
        'I can have two rows of data for i1, so i2 would start on row 4, if I would have 3 sets of data for i1, i2 would start on row 5. remember headers are on row 1
    
            ' ******  Redundant ????   '*******  'With ws4 'because it's where we copy the data as individuals - before merging
        
                ws4.Range("A2:BC" & lr3).Copy 'copies data from ws4
                ws2.Cells(lr1, 1).PasteSpecial Paste:=xlPasteValues 'pastes ws4 data as values on ws2, ws2 is the refresh sheet on the merging workbook
            
            '**** Redundant ?????   ' End With '*****
        
        '  ******* Redundant ??? ' **End With******
    
        Application.CutCopyMode = False
    
    Next i
 
ws2.Activate 'when the loop ends, we activate ws2

ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "Atualizar ST" & ".xlsx", FileFormat:=xlOpenXMLWorkbook 'in order to not lose the template, we saveas on the same destination with a new name

ActiveWorkbook.Close 'close the brand new renamed workbook

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Hey Snakehips, I ammended the code and here is the final version with updated blocks of columns. Hope this looks cleaner. However, I'm having troubles with the Workbooks.Open And Set wb2 (both highlighted as a commentary), since I don't know which syntax I should use to get it running flawlessly.

Could you provide some help please? Code as follows

Sub integrar()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, i As Long
Dim mypath As String, docname As String, filtervalue As String

Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("PainelControlo")
Set ws2 = wb1.Worksheets("MACRO 1")
Set ws3 = wb1.Worksheets("Tipificação Feedback")

lr1 = ws2.Cells(Rows.Count, "A").End(xlUp).Row

ws2.Activate

    For i = 2 To lr1
  
        lr2 = ws3.Cells(Rows.Count, "A").End(xlUp).Row + 1
  
        filtervalue = Cells(i, 5).Value
  
        Workbooks.Open Filename:=ThisWorkbook.Path & "\Controlo e Difusão\Feedbacks Recebidos\" & filtervalue & ".xlsx" 'here
  
        Set wb2 = Workbooks(filtervalue ".xlsx") 'here
      
        Set ws4 = wb2.Worksheets("Pendentes")
  
        lr3 = ws4.Cells(Rows.Count, "A").End(xlUp).Row
      
            With ws4
          
                .Range("D2:D" & lr3).Copy
                ws3.Cells(lr2, 2).PasteSpecial Paste:=xlPasteValues
              
                .Range("AT2:AT" & lr3).Copy
                ws3.Cells(lr2, 3).PasteSpecial Paste:=xlPasteValues
              
                .Range("AX2:AZ" & lr3).Copy
                ws3.Cells(lr2, 4).PasteSpecial Paste:=xlPasteValues
              
            End With
          
        ActiveWorkbook.Close
      
        Application.CutCopyMode = False
      
        ws3.Activate
      
    Next i
  
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Thanks Snakehips and sorry for late answer!

 

[jalrs]

@Snakehips Hello again,

I went back and forth today versus my code trying to find a solution to the question above this post that eventually I ended up running it.
My problem now is that it is not copying all the expected rows, plus it is pasting from last opened to first opened, instead of pasting first opened workbook first, second second, third third, etc etc

Any help is greatly appreciated

The code is running as follows:

Sub integrar()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, i As Long
Dim mypath As String, docname As String, filtervalue As String

Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("PainelControlo")
Set ws2 = wb1.Worksheets("MACRO 1")
Set ws3 = wb1.Worksheets("TFDB")

ws2.Activate

lr1 = ws2.Cells(Rows.Count, "E").End(xlUp).Row

    For i = 2 To lr1
    
        filtervalue = Cells(i, 5).Value
    
        lr2 = ws3.Cells(Rows.Count, "A").End(xlUp).Row + 1
    
        Workbooks.Open Filename:=ThisWorkbook.Path & "\Controlo e Difusão\Feedbacks Recebidos\" & Cells(i, 5).Value & ".xlsx"
    
        Set wb2 = Workbooks("" & filtervalue & ".xlsx")
        
        Set ws4 = wb2.Worksheets("Pendentes")
    
        lr3 = ws4.Cells(Rows.Count, "A").End(xlUp).Row
        
            With ws4
            
                .Range("D2:D" & lr3).Copy
                ws3.Cells(lr2, 2).PasteSpecial Paste:=xlPasteValues
                
                .Range("AT2:AT" & lr3).Copy
                ws3.Cells(lr2, 3).PasteSpecial Paste:=xlPasteValues
                
                .Range("AX2:AZ" & lr3).Copy
                ws3.Cells(lr2, 4).PasteSpecial Paste:=xlPasteValues
                
            End With
            
        ActiveWorkbook.Close
        
        Application.CutCopyMode = False
        
        ws2.Activate
        
    Next i
    
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Thanks Snakehips

 

[jalrs]

Hello @Snakehips

I went back and forth again today and managed to ammend the code to get it fully working and intended.
Would like to hear on your side if there are any redundant things that I may ammend as well.

Final version:

Sub integrar()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, lr5 As Long, lr6 As Long, lr7 As Long, i As Long
Dim mypath As String, docname As String, filtervalue As String

Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("PainelControlo")
Set ws2 = wb1.Worksheets("MACRO 1")
Set ws3 = wb1.Worksheets("TFDB")

ws2.Activate

lr1 = ws2.Cells(Rows.Count, "E").End(xlUp).Row

    For i = 2 To lr1
    
        filtervalue = Cells(i, 5).Value
    
        lr2 = ws3.Cells(Rows.Count, "B").End(xlUp).Row + 1
        lr3 = ws3.Cells(Rows.Count, "C").End(xlUp).Row + 1
        lr4 = ws3.Cells(Rows.Count, "D").End(xlUp).Row + 1
    
        Workbooks.Open Filename:=ThisWorkbook.Path & "\Controlo e Difusão\Feedbacks Recebidos\" & Cells(i, 5).Value & ".xlsx"
    
        Set wb2 = Workbooks("" & filtervalue & ".xlsx")
        
        Set ws4 = wb2.Worksheets("Pendentes")
    
        lr5 = ws4.Cells(Rows.Count, "D").End(xlUp).Row
        lr6 = ws4.Cells(Rows.Count, "AT").End(xlUp).Row
        lr7 = ws4.Cells(Rows.Count, "AX").End(xlUp).Row
        
            With ws4
            
                .Range("D2:D" & lr5).Copy
                ws3.Cells(lr2, 2).PasteSpecial Paste:=xlPasteValues
                
                .Range("AT2:AT" & lr6).Copy
                ws3.Cells(lr3, 3).PasteSpecial Paste:=xlPasteValues
                
                .Range("AX2:AZ" & lr7).Copy
                ws3.Cells(lr4, 4).PasteSpecial Paste:=xlPasteValues
                
            End With
            
        ActiveWorkbook.Close
        
        Application.CutCopyMode = False
        
        ws2.Activate
        
    Next i
    
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Thanks!

 

[Snakehips]

@jairs Sorry for delayed response but have been non-comunicado for a couple of days.
That's great. You have working code and it does look to be tidily coded. If it works and you are happy with it then keep it as is.

Any comments I make now are perhaps being rather picky.
Bear in mind that non of what I say is tested. Hopefully I have neither been careless of misinterpreted anything.

The main thing I would do different is to code a transfer of values rather than unnecessarily use Copy/ Paste Special Values.
That generally removes any need for selections or activations etc.
There are one or two other comments I have made within the code that hopefully make sense.
Eg I would have some of the last row calcs outside the loop and then just increment them +1 within the loop.
I also offer an alternative to Opening the filtervalue file which might avoid any annoyance as those files open / close.

Sub integrar()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, lr5 As Long, lr6 As Long, lr7 As Long, i As Long
Dim mypath As String, docname As String, filtervalue As String

Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("PainelControlo")
Set ws2 = wb1.Worksheets("MACRO 1")
Set ws3 = wb1.Worksheets("TFDB")


'ws2.Activate  *** not necessary if not using Copy Paste?

lr1 = ws2.Cells(Rows.Count, "E").End(xlUp).Row

        '****compute these last rows just once, outside the loop and then increment within the loop ?
        lr2 = ws3.Cells(Rows.Count, "B").End(xlUp).Row
        lr3 = ws3.Cells(Rows.Count, "C").End(xlUp).Row
        lr4 = ws3.Cells(Rows.Count, "D").End(xlUp).Row



    For i = 2 To lr1
   
        lr2 = lr2 + 1
        lr3 = lr3 + 1
        lr4 = lr4 + 1
       
        filtervalue = Cells(i, 5).Value
   
       
   '**********************
       '** Could now use the variable filtervalue ?
       Workbooks.Open FileName:=ThisWorkbook.Path & "\Controlo e Difusão\Feedbacks Recebidos\" & filtervalue & ".xlsx"
        Set wb2 = Workbooks(filtervalue & ".xlsx")  '***   ??  "" & ??
       
        Set ws4 = wb2.Worksheets("Pendentes")
    '*********************
       
      '!!!!**********
      'If the above generates annoying flashes of file opening then maybe do by replacing above with single line below?
      'Remove '***   to actuate the below and comment out or delete the above
     
     '*** Set ws4 = GetObject(ThisWorkbook.Path & "\Controlo e Difusão\Feedbacks Recebidos\" & filtervalue & ".xlsx").Worksheets("Pendentes")
          
      '!!!!**********
       
            With ws4
           
                'Can bring these 3 last row statements into the With if you wish ?
                lr5 = .Cells(Rows.Count, "D").End(xlUp).Row
                lr6 = .Cells(Rows.Count, "AT").End(xlUp).Row
                lr7 = .Cells(Rows.Count, "AX").End(xlUp).Row
           
            'If pasting only values, why use Copy paste.  Just assign values?
              
                ws3.Cells(lr2, 2).Value = .Range("D2:D" & lr5).Value
           
                ws3.Cells(lr3, 3).Value = .Range("AT2:AT" & lr6).Value
               
                ws3.Cells(lr4, 4).Value = .Range("AX2:AZ" & lr7).Value
               
            End With
       '**************
        wb2.Close      'Original
        ''*************
       
        '!!!!!*********** Or alternatively if non-opening file, swap for below
        '*** ws4.Parent.Close SaveChanges:=False
        '!!!!!***********
       
        'Application.CutCopyMode = False  ***Redundant if not usingCopy Paste ?
       
        'ws2.Activate  *** not necessary if not using Copy Paste?
       
    Next i
   
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Hope that helps.