Copy cell from various tabs

[detolicious]

Hi there,

So I've got this code embedded in a userform that allows me to run a summary sheet. What it does is, open all excel files in a specified folder, copy a cell and paste it on the summary sheet, save the workbook and open the next one.

This way I can get data from hundreds of files by only clicking one button instead of opening every single file manually.

I am at an impasse now though, because it will only open the first tab and not other tabs if there are any. I was wondering if I can implement a line that says to check for other tabs and do the same there...

see the code below:

Sub YouBroughtThisOnYourself()
Dim oWbk As Workbook
Dim sFil As String
Dim sPath As String
Dim i As Integer

sPath = "L:\_Everyone\Dino\DEV0_Windwalk\livefeed"
ChDir sPath
sFil = Dir(sPath & "\*.xls")
Do While sFil <> ""
Set oWbk = Workbooks.Open(sPath & "\" & sFil)

ActiveSheet.Range("D6").Select
Selection.Copy
Workbooks("ww1.xls").Activate
Range("A1").Select
Do Until ActiveCell.Row = 65536
    Selection.End(xlDown).Select
Loop
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
Application.CutCopyMode = False

oWbk.Save
oWbk.Close
sFil = Dir
Loop

Application.Wait Now + TimeSerial(0, 0, 5)

then it repeats itself with another Cell, D7 for example.

Any ideas?

Thanks,
Dino

 

[pboltonchina]

try changing

ActiveSheet.Range("D6").Select
Selection.Copy
Workbooks("ww1.xls").Activate
Range("A1").Select
Do Until ActiveCell.Row = 65536
    Selection.End(xlDown).Select
Loop
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
Application.CutCopyMode = False

to

For Each WS In Sheets
        WS.Activate
Range("D6").Select
Selection.Copy
Workbooks("ww1.xls").Activate
Range("A1").Select
Do Until ActiveCell.Row = 65536
    Selection.End(xlDown).Select
Loop
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
Application.CutCopyMode = False
Next WS

 

[detolicious]

works perfectly at least the first set - but the following tabs aren't called. I keep getting "next without for"-error message.

 

[detolicious]

nevermind, found a way around it.

Sub YouBroughtThisOnYourself()

Dim oWbk As Workbook
Dim WS As Worksheet
Dim sFil As String
Dim sPath As String
Dim i As Integer
 
sPath = "L:\Dino\DEV0_Windwalk\livefeed"
ChDir sPath
sFil = Dir(sPath & "\*.xls")
Do While sFil <> ""
Set oWbk = Workbooks.Open(sPath & "\" & sFil)
 
For Each WS In Sheets
        WS.Activate
Range("D6").Select
Selection.Copy
Workbooks("ww1.xls").Activate
Range("A1").Select
Do Until ActiveCell.Row = 65536
    Selection.End(xlDown).Select
Loop
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
Application.CutCopyMode = False
Next WS
 
Application.Wait Now + TimeSerial(0, 0, 5)
 
oWbk.Save
oWbk.Close
sFil = Dir
Loop
 
sPath = "L:\Dino\DEV0_Windwalk\livefeed"
ChDir sPath
sFil = Dir(sPath & "\*.xls")
Do While sFil <> ""
Set oWbk = Workbooks.Open(sPath & "\" & sFil)
 
For Each WS In Sheets
        WS.Activate
Range("D7").Select
Selection.Copy
Workbooks("ww1.xls").Activate
Range("B1").Select
Do Until ActiveCell.Row = 65536
    Selection.End(xlDown).Select
Loop
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
Application.CutCopyMode = False
Next WS
 
Application.Wait Now + TimeSerial(0, 0, 5)

only downside, it's also taking the hidden tabs - not too bad though thanks 'pboltonchina' for the help, much appreciated!