Export cell values from multiple saved workbooks to single new workbook

[Padthelad]

I have the following recorded VBA code to copy a value from a particular cell in to a new workbook and then copy the value from the adjacent cell in to the same new workbook. Currently it only runs for the two workbooks I recorded. Is there a way for the VBA code to run through all the workbooks in a particular folder automatically? I would also like the code to be able to automatically 'dont save' the workbooks, as currently I have to click 'dont save' each time.

Any help anyone can provide is very much appreciated.

Thanks,

Patrick

Sub Macro2()
'
' Macro2 Macro
'

'
    Workbooks.Open Filename:= _
        "K:\***GENERIC FILENAME***.xlsm"
    Sheets("Quote").Select
    ActiveWindow.SmallScroll Down:=12
    Range("B40:C40").Select
    Selection.copy
    Windows("Book1").Activate
    Range("A1:B1").Select
    ActiveSheet.Paste
    Range("C1").Select
    Windows("***GENERIC FILENAME***.xlsm").Activate
    Range("B34:C34").Select
    Application.CutCopyMode = False
    Selection.copy
    Windows("Book1").Activate
    ActiveSheet.Paste
    Windows("***GENERIC FILENAME***.xlsm").Activate
    ActiveWindow.Close
    Workbooks.Open Filename:= _
        "K:\***GENERIC FILENAME 2***.xlsm"
    Sheets("Quote").Select
    ActiveWindow.SmallScroll Down:=9
    Range("B40:C40").Select
    Selection.copy
    Windows("Book1").Activate
    Range("A2").Select
    ActiveSheet.Paste
    Windows("***GENERIC FILENAME 2***.xlsm").Activate
    Range("B34:C34").Select
    Application.CutCopyMode = False
    Selection.copy
    Windows("Book1").Activate
    Range("C2").Select
    ActiveSheet.Paste
    Windows("***GENERIC FILENAME 2***.xlsm").Activate
    ActiveWindow.Close
End Sub

 

[Fluff]

If you still need help on this, how about

Sub GetFileData()
   Dim Wbk As Workbook
   Dim Ws As Worksheet
   Dim Pth As String
   Dim Fname As String
   
   Pth = "[COLOR=#ff0000]C:\MrExcel\Test\Fluff\[/COLOR]"
   Set Ws = Sheets("[COLOR=#ff0000]Sheet2[/COLOR]")
   
   Fname = Dir(Pth & "*.xlsx")
   Do While Fname <> ""
      Set Wbk = Workbooks.Open(Pth & Fname)
      With Wbk.Sheets("Quote")
         .Range("B40:C40").Copy Ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         .Range("B34:C34").Copy Ws.Range("C" & Rows.Count).End(xlUp).Offset(1)
      End With
      Wbk.Close False
      Fname = Dir
   Loop
End Sub

Change values in red to suit, where Sheet2 is the output sheet