Loop Reading Wrong Value

jalrs

Active Member
Joined
Apr 6, 2022
Messages
300
Office Version
  1. 365
Platform
  1. Windows
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:

VBA 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!
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
@jalrs
I reckon the Paste Special is negating the active status of ws3.
Try bringing the ws3.Activate inside of the loop.

VBA Code:
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.
 
Upvote 0
Solution
@jalrs
I reckon the Paste Special is negating the active status of ws3.
Try bringing the ws3.Activate inside of the loop.

VBA Code:
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
 
Upvote 0
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?

VBA Code:
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
 
Upvote 0
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?

VBA Code:
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!
 
Upvote 0
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?

VBA Code:
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!
 
Upvote 0
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?

VBA Code:
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
VBA Code:
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!
 
Upvote 0
@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:

VBA Code:
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
 
Upvote 0
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:
VBA Code:
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!
 
Upvote 0
@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.

VBA Code:
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.
 
Upvote 0

Forum statistics

Threads
1,213,551
Messages
6,114,266
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top