can you review this macro plz?

cmefly

cmefly

Well-known Member
Joined
May 13, 2003
Messages
683
hi,

I've got the following macro that goes into every excel file in a certain directory and copies certain cells to another worksheet...for some reason, it's not finding any files even though i clearly have 65 files in the directory...any help would be greatly appreciated.

Sub fetch2011columns()
Dim a, k As Integer
Dim strPath As String
Dim strFileName As String
Dim i As Integer
Dim vaFileName As Variant


strPath = "C:\2011"
a = 1

With Application.FileSearch
.LookIn = strPath
.Filename = ".xls"


For Each vaFileName In .FoundFiles
Workbooks.Open vaFileName

With ActiveWorkbook
.Worksheets("DataFetcher").Select
.Range("C5:C240, e5:e240,j5:j240,m5:m240").Select
.Close
End With

Windows("2011extractor").Activate
Range("A" & a).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

a = 240 * k + 1

Next

End With

End Sub


thanks,

Marc
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Sort by date Sort by votes
A couple of things:

You need the data type for the "a" variable, NB The k variable is not used.
Dim a As Integer, k As Integer

You have missed out a few things for the Filesearch.
Note the use of the wildcard for the filename:
Code: 
   [COLOR=darkblue]With[/COLOR] Application.FileSearch
      .NewSearch
      .LookIn = strPath
      .FileType = msoFileTypeExcelWorkbooks
      .Filename = "*.xls"
If any Excel files are found the loop through the files:
Code: 
      [COLOR=darkblue]If[/COLOR] .Execute > 0 [COLOR=darkblue]Then[/COLOR] [COLOR=green]'files found[/COLOR]
         
         [COLOR=darkblue]For[/COLOR] i = 1 [COLOR=darkblue]To[/COLOR] .FoundFiles.Count
You will need a workbook variable to open the file,
And I think you want to copy the range not select.
Then close the workbook:
Code: 
            [COLOR=green]'open the file, copy the range and close the file[/COLOR]
            [COLOR=darkblue]Set[/COLOR] wb = Workbooks.Open(Filename:=.FoundFiles(i), UpdateLinks:=0)
            wb.Worksheets("DataFetcher").Range("C5:C240, e5:e240,j5:j240,m5:m240").Copy
            wb.Close SaveChanges:=[COLOR=darkblue]False[/COLOR]
And I think that should be you all set.

The full code is below.
NB I have not tested the code. I am only offering a few guidelines.
Code: 
[COLOR=darkblue]Sub[/COLOR] fetch2011columns()
   [COLOR=darkblue]Dim[/COLOR] a [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Integer[/COLOR], k [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Integer[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] strPath [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] strFileName [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] i [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Integer[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] wb [COLOR=darkblue]As[/COLOR] Workbook

   strPath = "C:\2001"
   a = 1

   [COLOR=darkblue]With[/COLOR] Application.FileSearch
      .NewSearch
      .LookIn = strPath
      .FileType = msoFileTypeExcelWorkbooks
      .Filename = "*.xls"
      
      [COLOR=darkblue]If[/COLOR] .Execute > 0 [COLOR=darkblue]Then[/COLOR] [COLOR=green]'files found[/COLOR]
         
         [COLOR=darkblue]For[/COLOR] i = 1 [COLOR=darkblue]To[/COLOR] .FoundFiles.Count
            
            [COLOR=green]'open the file, copy the range and close the file[/COLOR]
            [COLOR=darkblue]Set[/COLOR] wb = Workbooks.Open(Filename:=.FoundFiles(i), UpdateLinks:=0)
            wb.Worksheets("DataFetcher").Range("C5:C240, e5:e240,j5:j240,m5:m240").Copy
            wb.Close SaveChanges:=[COLOR=darkblue]False[/COLOR]
   
            [COLOR=green]'paste the range[/COLOR]
            Sheets("2011extractor").Range("A" & a).PasteSpecial _
                  Paste:=xlPasteValues, _
                  Operation:=xlNone, _
                  SkipBlanks:=False, _
                  Transpose:=[COLOR=darkblue]False[/COLOR]
            Application.CutCopyMode = [COLOR=darkblue]False[/COLOR]
   
            a = 240 * k + 1
         [COLOR=darkblue]Next[/COLOR] i
         
      [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
   [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
End [COLOR=darkblue]Sub[/COLOR]
 
Upvote 0
Bertie,

Thank you for taking the time to break things out and explain things to me.

I'm giving it a shot right now and will post back in a few minutes with the results.

thank you so so much

Marc
 
Upvote 0
Bertie,

so a couple of things.

1. when i'm copying the info and then close the file, i get a pop-up message saying its a large amount of data etc etc....how do i disable this?

2. the code won't do the paste special into the new file...can you take a quick look?


Sub fetch2011columns()
Dim a As Integer, k As Integer
Dim strPath As String
Dim strFileName As String
Dim i As Integer
Dim wb As Workbook

strPath = "C:\2011"
a = 1

With Application.FileSearch
.NewSearch
.LookIn = strPath
.FileType = msoFileTypeExcelWorkbooks
.Filename = "*.xls"

If .Execute > 0 Then 'files found

For i = 1 To .FoundFiles.Count

'open the file, copy the range and close the file
Set wb = Workbooks.Open(Filename:=.FoundFiles(i), UpdateLinks:=0)
wb.Worksheets("DataFetcher").Range("C5:C240, e5:e240,j5:j240,m5:m240").Copy
wb.Close SaveChanges:=False

'paste the range (Bertie, i change your code here in order to activate the new file

Windows("2011dataextractor.xls").Activate


Sheets("Sheet1").Range("A" & a).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


Application.CutCopyMode = False

a = 240 * k + 1
Next i

End If
End With
End Sub
 
Upvote 0
Try closing the workbook after the paste, see highlighted below:
Code: 
[COLOR=darkblue]Sub[/COLOR] fetch2011columns()
   [COLOR=darkblue]Dim[/COLOR] a [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Integer[/COLOR], k [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Integer[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] strPath [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] strFileName [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] i [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Integer[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] wb [COLOR=darkblue]As[/COLOR] Workbook

   strPath = "C:\2001"
   a = 1

   [COLOR=darkblue]With[/COLOR] Application.FileSearch
      .NewSearch
      .LookIn = strPath
      .FileType = msoFileTypeExcelWorkbooks
      .Filename = "*.xls"
      
      [COLOR=darkblue]If[/COLOR] .Execute > 0 [COLOR=darkblue]Then[/COLOR] [COLOR=green]'files found[/COLOR]
         
         [COLOR=darkblue]For[/COLOR] i = 1 [COLOR=darkblue]To[/COLOR] .FoundFiles.Count
            
            [COLOR=green]'open the file, copy the range and close the file[/COLOR]
            [COLOR=darkblue]Set[/COLOR] wb = Workbooks.Open(Filename:=.FoundFiles(i), UpdateLinks:=0)
            wb.Worksheets("DataFetcher").Range("C5:C240, e5:e240,j5:j240,m5:m240").Copy
   
            [COLOR=green]'paste the range[/COLOR]
            Sheets("2011extractor").Range("A" & a).PasteSpecial _
                  Paste:=xlPasteValues, _
                  Operation:=xlNone, _
                  SkipBlanks:=False, _
                  Transpose:=[COLOR=darkblue]False[/COLOR]
            Application.CutCopyMode = [COLOR=darkblue]False[/COLOR]
   
[COLOR=Red]            wb.Close SaveChanges:=[/COLOR][COLOR=Red]False
            [/COLOR][COLOR=Red]Set wb = [/COLOR][COLOR=Red]Nothing[/COLOR]
            a = 240 * k + 1
         [COLOR=darkblue]Next[/COLOR] i
         
      [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
   [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
End [COLOR=darkblue]Sub[/COLOR]
The line set wb=Nothing clears the memory set aside for the workbook variable.

You shouldn't get any other alerts.

ps When posting code click on the hash (#) in the toolbar and place your code inside the tags. This preserves indentation and makes the code easier to read.

Bertie
 
Upvote 0
Edit

To disable the clipboard alert when closing the workbook try this:
Code: 
            Application.DisplayAlerts = [COLOR=darkblue]False[/COLOR]
               wb.Close SaveChanges:=[COLOR=darkblue]False[/COLOR]
            Application.DisplayAlerts = [COLOR=darkblue]True[/COLOR]
 
Upvote 0
sorry bertie, i don't have that toolbar to allow me to press (#)...not sure why..

in any case, i'm getting a runtime error 1004 at the line indicated with the **

you mentioned to close the workbook but i can't since it is the main file that will be collecting the data from all the files in the directory. For some reason, i can't get the pastespecial to work properly.


#
Sub fetch2011columns()
Dim a As Integer, k As Integer
Dim strPath As String
Dim strFileName As String
Dim i As Integer
Dim wb As Workbook

Application.DisplayAlerts = False

strPath = "C:\2011 New Tariff Schedules"
a = 1

With Application.FileSearch
.NewSearch
.LookIn = strPath
.FileType = msoFileTypeExcelWorkbooks
.Filename = "*.xls"

If .Execute > 0 Then 'files found

For i = 1 To .FoundFiles.Count

'open the file, copy the range and close the file
Set wb = Workbooks.Open(Filename:=.FoundFiles(i), UpdateLinks:=0)
wb.Worksheets("DataFetcher").Range("C5:C240, e5:e240,j5:j240,m5:m240").Copy
wb.Close SaveChanges:=False

'paste the range
Windows("2011dataextractor.xls").Activate


Sheets("Sheet1").Range("A" & a).Select

'**
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False



Application.CutCopyMode = False

a = 240 * k + 1
Next i

End If
End With
End Sub
 
Upvote 0
Yep, I have had a chance to test the code and found the problem, well two actualy.

Problem 1 It didn't like:
Code: 
Sheets("2011extractor").Range("A" & a).PasteSpecial
So lets create another workbook variable and change it to:
Code: 
wbThis.Sheets("2011extractor").Range("A" & a).PasteSpecial
Problem 2
The variable k=0 , this is resetting the variable a meaning everything is getting overwritten.

The amended code is below.

Code: 
[COLOR=darkblue]Sub[/COLOR] fetch2011columns()
   [COLOR=darkblue]Dim[/COLOR] a [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Integer[/COLOR], k [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Integer[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] strPath [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] strFileName [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] i [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Integer[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] wb [COLOR=darkblue]As[/COLOR] Workbook
   
[COLOR=Red]Dim wbThis [/COLOR][COLOR=Red]As Workbook
   [/COLOR][COLOR=Red]Set wbThis = ThisWorkbook[/COLOR]

   strPath = "C:\2001"
   a = 1
   
   [COLOR=darkblue]With[/COLOR] Application.FileSearch
      .NewSearch
      .LookIn = strPath
      .FileType = msoFileTypeExcelWorkbooks
      .Filename = "*.xls"
      
      [COLOR=darkblue]If[/COLOR] .Execute > 0 [COLOR=darkblue]Then[/COLOR] [COLOR=green]'files found[/COLOR]
         
         [COLOR=darkblue]For[/COLOR] i = 1 [COLOR=darkblue]To[/COLOR] .FoundFiles.Count
            
            [COLOR=green]'open the file, copy the range and close the file[/COLOR]
            [COLOR=darkblue]Set[/COLOR] wb = Workbooks.Open(Filename:=.FoundFiles(i), UpdateLinks:=0)
            wb.Worksheets("DataFetcher").Range("C5:C240, e5:e240,j5:j240,m5:m240").Copy
   
            [COLOR=green]'paste the range[/COLOR]
            [COLOR=Red]wbThis.Sheets("2011extractor")[/COLOR].Range("A" & a).PasteSpecial _
                  Paste:=xlPasteValues, _
                  Operation:=xlNone, _
                  SkipBlanks:=False, _
                  Transpose:=[COLOR=darkblue]False[/COLOR]
            Application.CutCopyMode = [COLOR=darkblue]False[/COLOR]
   
            Application.DisplayAlerts = [COLOR=darkblue]False[/COLOR]
               wb.Close SaveChanges:=[COLOR=darkblue]False[/COLOR]
            Application.DisplayAlerts = [COLOR=darkblue]True[/COLOR]
            [COLOR=darkblue]Set[/COLOR] wb = [COLOR=darkblue]Nothing[/COLOR]
           [COLOR=Red] a = 240 + 1[/COLOR]
         [COLOR=darkblue]Next[/COLOR] i
         
      [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
   [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
   Set wbThis=Nothing
End [COLOR=darkblue]Sub[/COLOR]
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question Question
Macro to Open File and limit selection where files contains "Parts" in C
Replies
4
Views
269
howard
H
H
  • Question Question
Macro: Convert pdf into Excel and extract certain data to put together with file name
Replies
1
Views
3K
HeinrichPaul
H
A
  • Question Question
Import Table Data from Web using VBA to excel Worksheet and able to input Values which can modify the web data to be extract
Replies
0
Views
658
Ambrosia
A
G
  • Solved
Data Import stopping after 16 rows
Replies
2
Views
461
grabrail
G
S
  • Question Question
Worksheet Change Event
Replies
2
Views
703
sspatriots
S

Forum statistics

Threads
1,224,590
Messages
6,179,763
Members
452,940
Latest member
rootytrip

Share this page

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