Read from many sheets VBA

[Jack in the UK]

Hi guys

A little project will be if i have say 250 to 1000 wkbks i need code to rip but row 1 from each into a report documents.

All the data will be lined up ok, ill make sure but the file names will be all sorts, no error check needeed just rip it over and return the data one under the other in the report document

Any ideas of a cleaver way guys

Many thanks in advance!

PS all will be in the same directory not scattered so locational issues are all taken care of and maintance all thats fine, just need from button on XLT to rip the XLS x 250+ over and add to the bottom

 

[XL-Dennis]

Jack,

I´m not sure if this is a cleaver way or not but at least it works

Paste following code in standardmodule and change the path to the directory and the name of the sheet that will receive all the data:

Option Explicit
Option Base 1<PRE><FONT color=blue>Sub</FONT>Copy_Data()<FONT color=blue>Dim</FONT>stFil<FONT color=blue> As</FONT><FONT color=blue> String</FONT>, stPath<FONT color=blue> As</FONT><FONT color=blue> String</FONT>, stFiltyp<FONT color=blue> As</FONT><FONT color=blue> String</FONT>, stFilArray()<FONT color=blue> As</FONT><FONT color=blue> String</FONT><FONT color=blue>Dim</FONT>wsDataRange<FONT color=blue> As</FONT> Worksheet<FONT color=blue>Dim</FONT>x<FONT color=blue> As</FONT><FONT color=blue> Long</FONT>, i<FONT color=blue> As</FONT><FONT color=blue> Long</FONT>



Application.ScreenUpdating =<FONT color=blue> False</FONT><FONT color=#ff0000>'Here You change to Your actual directory</FONT>
stPath = "c:Test"



stFiltyp = "*.xls"



stFil = Dir(stPath & stFiltyp)<FONT color=blue>Debug.Print</FONT> stFil<FONT color=blue>Do</FONT><FONT color=blue>Until</FONT> stFil = ""

i = i + 1

ReDim<FONT color=blue> Preserve</FONT> stFilArray(i)

stFilArray(i) = stFil

stFil = Dir<FONT color=blue>Loop</FONT><FONT color=blue>Set</FONT>wsDataRange = ThisWorkbook.Sheets("Data")<FONT color=blue>For</FONT>x =<FONT color=blue>LBound</FONT>(stFilArray)<FONT color=blue>To</FONT><FONT color=blue>UBound</FONT>(stFilArray)<FONT color=blue> Workbook</FONT>s.<FONT color=blue>Open</FONT>(stPath & stFilArray(x))

Worksheets("Blad1").Range("A1").Copy

wsDataRange.Cells(x, 1).PasteSpecial Paste:=xlValues<FONT color=blue> Workbook</FONT>s(stFilArray(x)).<FONT color=blue>Close</FONT>Savechanges:=False<FONT color=blue>Next</FONT>x



Application.ScreenUpdating =<FONT color=blue> True</FONT><FONT color=blue>End Sub</FONT></PRE>

HTH,
Dennis


_________________
"Windows was not able to find any keyboard. Press F1-button to try again or F2-button for cancel."
This message was edited by XL-Dennis on 2002-08-24 07:23

 

[Jack in the UK]

Hi Dennis

Cheers my old fiend, ill try and post back on this feed im working hard and this ones a pain, but solvable, getting more and more to do. Not chatted in a bit so i pass on my very best to you and ill PM email you soon for a better chat

Thanks again dennis

Jack

 

[Jack in the UK]

Dennis

Well my good friend that code needed a tweek or two but DAM thats PERFECTION, i recomend you all grab this one and it will come in usefull....

Cheers Dennis chat soon

Your friend Jack

 

[XL-Dennis]

Jack,

Glad it worked altough it´s neither clever or perfection just decent coding :wink:

Kind regards,
Dennis

 

[Jack in the UK]

Dennis

im proud weare friends !!!

What else to say ????

Little i feel, amybe one day i can code as well , im thinking Jack doubt that one, some good friends thay know who they are no need to name them, you are one.

Hey keep in touch, look after sweeden!!!

You friend Jack in South London!!