Kristylee0228
New Member
- Joined
- Sep 8, 2011
- Messages
- 30
I have a Summary Document that I need names auto-populated into Column J. The Names are already in a list that shows in a Drop-Down.
I have a Macro that runs through a folder and pastes data into this Summary Sheet.
The Names I need populated that show in the Drop-Down List are the File Names of each file within the Folder.
See below the Macro I use:
Below this is an image of the file I need the names populated into Column J. ( I can get rid of the Drop-Down List if I don't need it.)
Sub MasterSummarySheet()
Dim MyFolder As String, MyFile As String
Dim EndRow As Long
Dim FirstBlankRow As Long
Dim SourceWb As Workbook
Dim SourceWs As Worksheet
Dim WsName As String
Dim DestWb As Workbook
Dim DestWs As Worksheet
Dim cellDataValue As String
Dim Rng As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.Clear
End With
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
MyFile = Dir(MyFolder & "\", vbReadOnly)
Do While MyFile <> ""
DoEvents
On Error GoTo 0
Set SourceWb = Workbooks.Open(Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False)
Sheets("RPC TIC SHEET").Select
Range("A5").Select
Range("B:J").EntireColumn.Hidden = True
Range("L:P").EntireColumn.Hidden = True
Range("R:V").EntireColumn.Hidden = True
Range("X:AB").EntireColumn.Hidden = True
Range("AD:AH").EntireColumn.Hidden = True
Range("AK:AM").EntireColumn.Hidden = True
EndRow = Range("A1").End(xlDown).Row
For i = 5 To EndRow 'start copy at row5 so not to include HeaderRow
Set DestWb = Workbooks.Open(Filename:="\\ncb-fs1\Compliance-QA\01 - QUALITY ASSURANCE - LISTENING\TIC SHEETS\Template_NCB_MMMYY_MASTER TICSHEET.xlsx")
Set DestWs = DestWb.ActiveSheet
FirstBlankRow = DestWs.Cells(Rows.Count, 1).End(xlUp).Row + 1
Rng = "A" & CStr(i) & ":AL" & CStr(i)
SourceWb.Sheets("RPC TIC SHEET").Range(Rng).SpecialCells(xlCellTypeVisible).Copy Destination:=DestWs.Range("A" & FirstBlankRow)
Next i
Workbooks(MyFile).Close SaveChanges:=False
MyFile = Dir
Loop
Application.ScreenUpdating = True
DestWb.SaveAs "\\ncb-fs1\Compliance-QA\01 - QUALITY ASSURANCE - LISTENING\TIC SHEETS\NCB_Master TicSheet " & Format(Date, "M-D-YY") & ".xlsx", FileFormat _
:=51, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
I have a Macro that runs through a folder and pastes data into this Summary Sheet.
The Names I need populated that show in the Drop-Down List are the File Names of each file within the Folder.
See below the Macro I use:
Below this is an image of the file I need the names populated into Column J. ( I can get rid of the Drop-Down List if I don't need it.)
Sub MasterSummarySheet()
Dim MyFolder As String, MyFile As String
Dim EndRow As Long
Dim FirstBlankRow As Long
Dim SourceWb As Workbook
Dim SourceWs As Worksheet
Dim WsName As String
Dim DestWb As Workbook
Dim DestWs As Worksheet
Dim cellDataValue As String
Dim Rng As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.Clear
End With
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
MyFile = Dir(MyFolder & "\", vbReadOnly)
Do While MyFile <> ""
DoEvents
On Error GoTo 0
Set SourceWb = Workbooks.Open(Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False)
Sheets("RPC TIC SHEET").Select
Range("A5").Select
Range("B:J").EntireColumn.Hidden = True
Range("L:P").EntireColumn.Hidden = True
Range("R:V").EntireColumn.Hidden = True
Range("X:AB").EntireColumn.Hidden = True
Range("AD:AH").EntireColumn.Hidden = True
Range("AK:AM").EntireColumn.Hidden = True
EndRow = Range("A1").End(xlDown).Row
For i = 5 To EndRow 'start copy at row5 so not to include HeaderRow
Set DestWb = Workbooks.Open(Filename:="\\ncb-fs1\Compliance-QA\01 - QUALITY ASSURANCE - LISTENING\TIC SHEETS\Template_NCB_MMMYY_MASTER TICSHEET.xlsx")
Set DestWs = DestWb.ActiveSheet
FirstBlankRow = DestWs.Cells(Rows.Count, 1).End(xlUp).Row + 1
Rng = "A" & CStr(i) & ":AL" & CStr(i)
SourceWb.Sheets("RPC TIC SHEET").Range(Rng).SpecialCells(xlCellTypeVisible).Copy Destination:=DestWs.Range("A" & FirstBlankRow)
Next i
Workbooks(MyFile).Close SaveChanges:=False
MyFile = Dir
Loop
Application.ScreenUpdating = True
DestWb.SaveAs "\\ncb-fs1\Compliance-QA\01 - QUALITY ASSURANCE - LISTENING\TIC SHEETS\NCB_Master TicSheet " & Format(Date, "M-D-YY") & ".xlsx", FileFormat _
:=51, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
Application.DisplayAlerts = True
End Sub