I have revised my code, It will work, but I have to run it several times.
Code:
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("C:\Users\Terry\Desktop\Kobes Files\workorders\Files\")
While (file <> "")
Call getalldata2(file)
file = Dir
Wend
End Sub
Code:
Sub getalldata2(fname)
Dim pth As String
Dim ws As Worksheet
Dim wb_to_find As String
Dim wkbk_open As Workbook
pth = "C:\Users\Terry\Desktop\Kobes Files\workorders\Files\"
wb_to_find = pth & fname
Set wkbk_open = Workbooks.Open(wb_to_find)
'This needs to be run several times go get several ranges
With wkbk_open.Worksheets(Left(fname, 4))
.Activate
.Range("d2,d4,d6").Copy
End With
With ThisWorkbook.Worksheets("Sheet1").Activate
'.Activate
Worksheets("Sheet1").Cells (Range("A65536").End(xlUp).Row + 1)
.Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With
'This takes the WorkOrder details and puts it on a second sheet, needs to be run 2 times so the workorder number can be put above it first (changing ranges each time)
With wkbk_open.Worksheets(Left(fname, 4))
.Activate
.Range("A8:J" & .Range("A65536").End(xlUp).Row).Copy
End With
With ThisWorkbook.Worksheets("Sheet2").Activate
Worksheets("Sheet2").Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub
[/code]
Im trying to find a way so that I don't need to hard code each time I need a new range.
Thank you for your code suggestions, it helped quite a bit.
Terry