Populating Cell based on File Name and using a List

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

1708035198898.png
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

Forum statistics

Threads
1,223,886
Messages
6,175,194
Members
452,616
Latest member
intern444

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top