VBA code not looping for compiling sheets from many workbooks in folder [SOLVED]

[gauravkrgautam]

Hi All,

i need little help in getting my code work properly. my codes are below what i want to do is i have folder(dir) named as "DAR" where are 150 workbooks but there are 30 workbooks with .xlsm format type and i am trying to compile them. but on running code first file (alphabetically first file with .xlsm file) is collating every time and code is going infinity.

here is the code :

[pre]

'=======================================================

Sub test()
Dim mwb As Workbook       'master workbook
Dim rfa As String         'resource folder address
Dim rfn As String         'resource file name
Dim fan As String         'file address and name
Dim nbr As Integer        'next to bottom row

Set mwb = ThisWorkbook
rfa = "C:Documents and SettingsuserDesktopantivirus ReportExternal ReportDAR"
'MsgBox rfa
rfn = Dir(rfa & "*.xlsm")
'MsgBox rfn
fan = rfa & rfn
'MsgBox fan
'Do While Len(rfn) > 0

Workbooks.Open (fan)
Workbooks(rfn).Sheets("backup").Range("a3:cz65000").Select
Selection.Copy
mwb.Activate
nbr = mwb.Sheets("sheet2").Range("b100000").End(xlUp).Row + 1
Sheets("sheet2").Range("b" & nbr).Select

With Selection
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteFormats
.CurrentRegion.Font.Size = 9
End With

Workbooks(rfn).Activate
Workbooks(rfn).Close False
'rfn = Dir
'Loop
End Sub

[/pre]

 

[gauravkrgautam]

when loop was not working properly i have changed related contents into remarks => line no. 15, 33 & 34 were changed into remarks when loop was not working f9

 

[Marc L]

Hi,


function Dir must be respected and you should read its VBA help !


Example :

[pre]

    MyPath = "D:Tests"
MyName = Dir(MyPath & "*.xlsm")

Do While MyName > ""
With Workbooks.Open(MyPath & MyName)
.Sheets("backup").[A3:CZ65000].Copy
'           …
.Close False
End With

MyName = Dir
Loop

[/pre]

 

[gauravkrgautam]

Thanks Marc L

code is working fine with first workbook but giving error in opening in next file

runtime error 1004

"Q'2 file001.xlsmQ'2 file002.xlsm"could not be found

error is showing 1st and 2nd file names together, above error consists of two file names

1st - Q'2 file001.xlsm

2nd - Q'2 file002.xlsm

my new code is as ==>

[pre]

Sub test()
Dim mwb As Workbook 'master workbook
Dim MyPath As String 'resource folder address
Dim MyName As String 'resource file name
Dim fan As String  'file address and name
Dim nbr As Integer
Set mwb = ThisWorkbook
MyPath = "C:Documents and SettingsuserDesktopSymantec ReportExternal ReportDAR"
MyName = Dir(MyPath & "*.xlsm")
'fan = MyPath & MyName
Do While MyName > ""
Workbooks.Open (MyPath & MyName)
Workbooks(MyName).Sheets("backup").Range("a3:cz65000").Select
Selection.Copy
mwb.Activate
nbr = mwb.Sheets("sheet2").Range("b100000").End(xlUp).Row + 1
Sheets("sheet2").Range("b" & nbr).Select
With Selection
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteFormats
.CurrentRegion.Font.Size = 9
End With
Workbooks(MyName).Activate
Workbooks(MyName).Close False
MyPath = Dir
Loop
End Sub

[/pre]

 

[SirJB7]

Hi, gauravkrgautam!

If any of the files has code for the workbook open event that might cause you some trouble. So unless specifically required you should set Application.EnableEvents to false at start and then to true at the end.

Regards!

 

[Marc L]

And removing these awful Activate & Select will be better and faster !


Fastest too by desactivating the ScreenUpdating …

 

[gauravkrgautam]

Thanks Marc L & SirJB7 for your guidance, as i am very new to vba codes so the codes are leangthy.


Thanks Once again for above all.

 

[SirJB7]

Hi, gauravkrgautam!

You're welcome, but could you solve your issue?

Regards!

 

[gauravkrgautam]

Thanks SirJB7 my problem was problem till yesterday night but now it is been resolved all files are compiling fine

coding shared by MarcL is working and tried my best to remove most of select and activate

i am very happy with this.

new coding ====

[pre]

Sub test()
Dim mwb As Workbook
Dim MyPath As String, MyName As String
Dim nbr As Integer

Application.ScreenUpdating = False
Set mwb = ThisWorkbook
MyPath = "C:Documents and SettingsuserDesktopSymantec ReportExternal ReportDAR"
MyName = Dir(MyPath & "*.xlsm")

Do While MyName > ""
With Workbooks.Open(MyPath & MyName)
.Sheets("backup").Range("a3:cz65000").Copy
End With

nbr = mwb.Sheets("sheet2").Range("b100000").End(xlUp).Row + 1
mwb.Activate
Sheets("sheet2").Range("b" & nbr).Select

With Selection
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteFormats
.CurrentRegion.Font.Size = 9
End With

Workbooks(MyName).Close False
MyName = Dir
Loop

Application.ScreenUpdating = True
End Sub

[/pre]
thanks you both it is resolved now.

 

[SirJB7]

Hi, gauravkrgautam!

Glad you solved it. Thanks for your feedback and welcome back whenever needed or wanted.

Regards!

 

[Marc L]

Hi gauravkrgautam !


Congrats but this is your code cleaned without any unnecessary awful Activate & Select wasting time :

[pre]

Sub Demo()
Dim MyName As String, MyPath As String, Rg As Range, Ws As Worksheet

Application.ScreenUpdating = False
Set Ws = ThisWorkbook.Sheets("sheet2")
MyPath = "C:Documents and SettingsuserDesktopSymantec ReportExternal ReportDAR"
MyName = Dir(MyPath & "*.xlsm")

Do While MyName > ""
Set Rg = Ws.Range("B" & Ws.Cells(Ws.Rows.Count, 2).End(xlUp).Row + 1)

With Workbooks.Open(MyPath & MyName)
.Sheets("backup").Range("A3:CZ65000").Copy
Rg.PasteSpecial xlPasteValues
Rg.PasteSpecial xlPasteColumnWidths
Rg.PasteSpecial xlPasteFormats
Rg.CurrentRegion.Font.Size = 9
.Close False
End With

MyName = Dir
Loop

Application.ScreenUpdating = True
End Sub

[/pre]

Regards !

 

[gauravkrgautam]

Wowww MarcL... is there any meter to measure happiness of learning new things , i will be at upmost in same.


will use same way in all my future coding

thanks very much Marc L & SirJB7