B
bsnapool
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
A PICTURE OF THE TEMPLATE IS ATTACHED, THIS TEMPLATE IS STANDARD ALL OF
THE 73 SHEETS WHICH MANAGERS USE.
I am not the best within VBA, so please forgive me. Would really
appreciate your help.
Cheers
Andrew
+-------------------------------------------------------------------+
|Filename: Pic of template.doc |
|Download: http://www.excelforum.com/attachment.php?postid=5064 |
+-------------------------------------------------------------------+
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
A PICTURE OF THE TEMPLATE IS ATTACHED, THIS TEMPLATE IS STANDARD ALL OF
THE 73 SHEETS WHICH MANAGERS USE.
I am not the best within VBA, so please forgive me. Would really
appreciate your help.
Cheers
Andrew
+-------------------------------------------------------------------+
|Filename: Pic of template.doc |
|Download: http://www.excelforum.com/attachment.php?postid=5064 |
+-------------------------------------------------------------------+