Extracting data from more than one files

[TG999]

Hello everybody
Tried on the pre defined solutions on the net but did not match.

In my excel file in sheet9 the first row is my own defined headers.
The output of the code will be from second row onwards.
On a command button click I want to open normal browse screen.
I will go in a particular drive in the required folder and pressing ctrl
key will select one or more than one excel files ( can be .xls or .xlsx or .xlsm ) and
give ok or open.
Why need browse screen because, evertime the target folder changes.
Imp:
Every file in the folder has a different header name in A1. Not to consider the names.
Every file in the folder has data in Sheet1 in column A and from A2 onwards, but since
all the Sheet1 has been differently renamed , kindly not consider the renamed sheet name
while defining the code. In code use Sheet1.

As I give open or ok, two things the code has to do.
1) Read the file names i.e before extension name and place all the names from column A to Z or
whatever but from second row.
2) Every file have values listed through out the column from
A2 onwards ( in the column there can be many cells in between that are blank ). Values
will be listed down from these file to sheet9 below the respective file names.

Thanks
TG999

 

[tonyyy]

Sub LoopFiles_1017016()
Application.ScreenUpdating = False
Dim fd As FileDialog
Dim wb As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long

Set ws = ThisWorkbook.Sheets("Sheet9")
''''Open FileDialog and select file(s)
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
    .InitialView = msoFileDialogViewList
    .AllowMultiSelect = True
    If .Show = 0 Then Exit Sub
End With
[COLOR=#ff0000]If ws.Cells(2, 1) <> "" Then
    j = ws.Cells(2, Columns.Count).End(xlToLeft).Column + 1
Else
    j = 1
End If[/COLOR]
''''Loop through selected file(s)
For i = 1 To fd.SelectedItems.Count
    Set wb = Workbooks.Open(fd.SelectedItems(i))
    ws.Cells(2, j).Value = Left(wb.Name, InStrRev(wb.Name, ".") - 1)
    wb.Sheets(1).Range("A2:A" & wb.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row).Copy Destination:=ws.Cells(3, j)
    j = j + 1
    wb.Close savechanges:=False
Next i
ws.Columns.AutoFit
Application.ScreenUpdating = True
MsgBox "The dishes are done, dude!"
End Sub

Replaced the original line "j = 1" with the code in red.

 

[TG999]

sorry Tonyy I did not notice the reply has been continued to page2.
I was trying to browse page one only.
I checked and is working fine.

Thanks a lot and sorry again for the delay.

Wanted one suggestion or link related to the issue.
From two days when I open a blank excel file. All the cells blinks.
An all the dropdown menus closes within 2 - 3 seconds.
Then opened a regular used file. Even there same problem.
Then opened Word. There also same problem of menus.
Any idea.

 

[tonyyy]

Thanks a lot and sorry again for the delay.

No worries; I was on holiday for the past week anyway. And you're very welcome.

As for all the cells blinking, I suggest you create a new post.