Vba Excellence Needed..... Please??

[bsnapool2006]

Hey Guys, Could really do with a hand. Needing a VBA whizz.

See if you can get your head round this?

Problem is:

In folder DHSC S&A, there is:

73 files, which are used by managers all with sheets 1-52 and masterentry, summary, monthly breakdown. The 1-52 represents 52 weeks of the year. I currently have code to copy the masterentry sheet to the relevant sheet when selected. There is also a summary file (This is were i am having problems with the code)

So all in all there are 74 files.

The code I have should open all sheets on the selected week (msg box), then look at the week number and copy the rows which have numeric digits in columns 6-12. starting from row 12.

When i run the macro within the summary file, it lists the names of the 73 files and trys opening the summary file which is already open. The code should be bringing back the rows which have numeric data in columns 6-12. starting at row 12.

I think the code is nearly there, but I think there may be something wrong with this bit?

Here is the code I got already.

Sub ListInfobyFile() 
 
'Determine what tab to look in, A1 should have 1-52 
ChWeek = InputBox("What Week") 
 
If 1 > ChWeek Or ChWeek > 52 Then 
Exit Sub 
Else 
End If 
 
Range("A1").Select 'Start of the new list. Change as required 
 
'Look in this file path to get a list of files in the folder, change this as required 
Folderpath = ThisWorkbook.Path 
Filenm = Dir(Folderpath & "\*.xls", vbNormal + vbReadOnly) 
 
i = 1 
Do While Filenm <> "" 
i = i + 1 
Filenm = Dir 
If Filenm = "" Then Exit Do 
 
'Paste the name 
ActiveCell.Offset(1, 0).Select 
ActiveCell.Value = Filenm 
 
'goto next row 
ActiveCell.Offset(1, 0).Select 
 
'open File 
Workbooks.Open Filename:=Folderpath & "\" & Filenm 
ActiveWB = ActiveWorkbook.Name 
 
'Goto Week Tab 
For Each ws In Worksheets 
If ws.Name = ChWeek Then 
Sheets(ChWeek).Select 
 
 
'Check Range 
'Determine number of rows to check 
countrows = Range("B12:B" & Range("B10000").End(xlUp).Row).Count 
 
'Check for values in F:L 
For r = 12 To 12 + countrows 
For c = 6 To 12 'Cols F:L 
If Application.IsNumber(Cells(r, c)) Then 'Copy row to Summary 
 
Rows(r).Copy 
ThisWorkbook.Activate 
Sheets("Summary").Select 
ActiveSheet.Paste 
ActiveCell.Offset(1, 0).Select 
Application.CutCopyMode = False 
Windows(ActiveWB).Activate 
Exit For 
End If 
Next c 
Next r 
GoTo NextFilenm 
End If 
Next ws 
 
NextFilenm: 
ActiveWorkbook.Close 
ThisWorkbook.Activate 
 
Loop 
 
End Sub

I am not the best within VBA, so please forgive me. Would really appreciate your help.

Cheers

Andrew

[mason12345]

Andrew:

You are missing one line in the code that is preventing you to open all 74 files:

Filenm = Dir(Folderpath & "\*.xls", vbNormal + vbReadOnly)
Range("D2").Select
ActiveCell.Value = Filenm  'this line is missing


also, consider removing the second row offset argument in the loop:

Do While Filenm <> ""
          
           i = i + 1
           Filenm = Dir
            If Filenm = "" Then Exit Do
             
            'Paste the name
            ActiveCell.Offset(1, 0).Select
            ActiveCell.Value = Filenm
             
            'goto next row
'            'ActiveCell.Offset(1, 0).Select ' removing this line causes your macro to print the list in consecutive row B2-BN, instead of everyother row.  I think this would look nicer.
         
Loop

Cheers,
-m