Hey Guys, Could really do with a hand. Needing a VBA whizz.
See if you can get your head round this?
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.