VBA copy one cell from multiple workbooks into a new workbook column

[Socrates055]

I am using Excel 2010 on Windows 7 Professional.

I have multiple excel workbooks (.xlsx) in a folder and i want to copy the value (not formula) from cell $C$5 and $D$7 into my Admin workbook that the VBA will be running in. I would like the value from each excel workbook to be placed in one column. i.e. first workbook in the folder would go into cell $A$3 and $B$3 respectively in the admin workbook, the second workbook in the folder would go into cell $A$4 and $B$4 respectively in the admin workbook, the third workbook in the folder would go into cell $A$5 and $B$5 respectively in the admin workbook and so on.

As an added bonus I would like a dialogue box pop up so I can select the folder the files are in. I found the code below that appears to do this.

Code taken from: https://answers.microsoft.com/en-us...n/7245c1b9-89ad-40fd-b16d-a3e2a3cded37?auth=1

Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet

Set WS = Sheets.Add

With Application.FileDialog(msoFileDialogFolderPicker)
.Show
myfolder = .SelectedItems(1) & ""
End With

Str = Application.InputBox(prompt:="Search string:", Title:="Search all workbooks in a folder", Type:=2)

If Str = "" Then Exit Sub

WS.Range("A1") = "Search string:"
WS.Range("B1") = Str
WS.Range("A2") = "Path:"
WS.Range("B2") = myfolder
WS.Range("A3") = "Workbook"
WS.Range("B3") = "Worksheet"
WS.Range("C3") = "Cell Address"
WS.Range("D3") = "Link"

a = 0

Value = Dir(myfolder)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm" Then
On Error Resume Next
Workbooks.Open Filename:=myfolder & Value, Password:="zzzzzzzzzzzz"
If Err.Number > 0 Then
WS.Range("A4").Offset(a, 0).Value = Value
WS.Range("B4").Offset(a, 0).Value = "Password protected"
a = a + 1
Else

 

[ManojRana]

Sub sufixrun()


Dim wb As Workbook, ws As Worksheet, lr As Integer, i As Integer


Set ws = ThisWorkbook.Sheets("55555") ' for suffix value update


With ws
For i = 6 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(i, 1) <> "" Then
sfx = .Cells(i, 1)
End If

Next
controlnumber ' calling conrol number value

End With



End Sub




Function controlnumber() ' for calling value of control number


Dim wb As Workbook, ws As Worksheet, j As Integer


Set ws = ThisWorkbook.Sheets("sheet1")
With ws

For j = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
amt = 0
If .Cells(j, 1) = 55555 Then
amt = amt + .Cells(j, 3)

End If


Next j
End With
End Function