problem with a macro

[eran3185]

i build a macro .
i want to copy the same sheet (7.07) from some workbooks (book1 , book11 , book111) to one large workbook (big).
i try to do this , but i get a macro that copy the sheets to new workbooks ...
what can i do to fix this problem ??


Sub teset()
Dim myDir As String, fn As String, a(), i As Integer, ws As Worksheet, LastR As Range
myDir = "C:\test\" '<- change to suite
fn = Dir(myDir & "book1*.xls")
Do While fn <> ""

With Workbooks.Open(myDir & fn)
.Sheets("7.07").Copy

'With Workbooks.Open(myDir & fn)
' .Sheets(4.07).Copy after:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
Set LastR = .Range("b5")
If Not IsEmpty(LastR) Then _
Set LastR = .Range("a" & Rows.Count).End(xlUp).Offset(1)
End With
With .Sheets(2).UsedRange
LastR.Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
.Close False
End With
fn = Dir()
Loop
'With ThisWorkbook
' ReDim a(1 To .Sheets.Count)
' For Each ws In Sheets
' i = i + 1: a(i) = ws.Name
' Next
' SortA a, 2, UBound(a)
'For Each e In a
' .Sheets(2).Move after:=.Sheets(.Sheets.Count)
' Next
' End With
End Sub

[Simon Lloyd]

Its possible that your problem is around the code in red below, because you are working with thisworkbook which is the workbook you just opened
[VBA]
Sub teset()
Dim myDir As String, fn As String, a(), i As Integer, ws As Worksheet, LastR As Range
myDir = "C:\test\" '<- change to suite
fn = Dir(myDir & "book1*.xls")
Do While fn <> ""

With Workbooks.Open(myDir & fn)
.Sheets("7.07").Copy

'With Workbooks.Open(myDir & fn)
' .Sheets(4.07).Copy after:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
Set LastR = .Range("b5")
If Not IsEmpty(LastR) Then _
Set LastR = .Range("a" & Rows.Count).End(xlUp).Offset(1)
End With
With .Sheets(2).UsedRange
LastR.Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
.Close False
End With
fn = Dir()
Loop
'With ThisWorkbook
' ReDim a(1 To .Sheets.Count)
' For Each ws In Sheets
' i = i + 1: a(i) = ws.Name
' Next
' SortA a, 2, UBound(a)
'For Each e In a
' .Sheets(2).Move after:=.Sheets(.Sheets.Count)
' Next
' End With
End Sub
[/VBA]Perhaps declaring thisworkbook (your original) will work
[VBA]
Sub teset()
Dim myDir As String, fn As String, a(), i As Integer, ws As Worksheet, LastR As Range
Dim MyWorkBook As Workbook
Set MyWorkBook = ThisWorkbook
myDir = "C:\test\" '<- change to suite
fn = Dir(myDir & "book1*.xls")
Do While fn <> ""

With Workbooks.Open(myDir & fn)
.Sheets("7.07").Copy

'With Workbooks.Open(myDir & fn)
' .Sheets(4.07).Copy after:=ThisWorkbook.Sheets(1)
With MyWorkbook.Sheets(1)
Set LastR = .Range("b5")
If Not IsEmpty(LastR) Then _
Set LastR = .Range("a" & Rows.Count).End(xlUp).Offset(1)
End With
With .Sheets(2).UsedRange
LastR.Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
.Close False
End With
fn = Dir()
Loop
'With ThisWorkbook
' ReDim a(1 To .Sheets.Count)
' For Each ws In Sheets
' i = i + 1: a(i) = ws.Name
' Next
' SortA a, 2, UBound(a)
'For Each e In a
' .Sheets(2).Move after:=.Sheets(.Sheets.Count)
' Next
' End With
End Sub
[/VBA]Just a thought!

[eran3185]

hey simon
it open me some files
i want to see all worksheets in one file only

[rory]

If you just copy a worksheet without specifying where to, you will create a new workbook and that is what you are doing with this:
[vba] With Workbooks.Open(myDir & fn)
.Sheets("7.07").Copy
[/vba]
You need something like this (assuming you want to copy to the workbook containing the code):
[vba] With Workbooks.Open(myDir & fn)
.Sheets("7.07").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
[/vba]

HTH
Rory

[eran3185]

hey
first of all - thenks
but i want that every file will copy in the same worksheet (not in some worksheet).
i want for example that in lines 1:30 will be the first file , in line 31:60 will be the second etc ...

[rory]

Then you don't want to copy the sheet at all. Try this:
[vba]Sub teset()
Dim myDir As String, fn As String, a(), i As Integer, ws As Worksheet, LastR As Range
myDir = "C:\test\" '<- change to suite
fn = Dir(myDir & "book1*.xls")
Do While fn <> ""

With Workbooks.Open(myDir & fn)
With ThisWorkbook.Sheets(1)
Set LastR = .Range("b5")
If Not IsEmpty(LastR) Then _
Set LastR = .Range("a" & Rows.Count).End(xlUp).Offset(1)
End With
With .Sheets("7.07").UsedRange
LastR.Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
.Close False
End With
fn = Dir()
Loop
'With ThisWorkbook
' ReDim a(1 To .Sheets.Count)
' For Each ws In Sheets
' i = i + 1: a(i) = ws.Name
' Next
' SortA a, 2, UBound(a)
'For Each e In a
' .Sheets(2).Move after:=.Sheets(.Sheets.Count)
' Next
' End With
End Sub
[/vba]

[eran3185]

the problem is that the worksheets are one on one , and i need that they will be one , then will be an empty row , then will be the second worksheet etc ...
it will be like that :

first worksheet
--------------
second worksheet
--------------
etc...

[rory]

Try changing this line:
Set LastR = .Range("a" & Rows.Count).End(xlUp).Offset(1)
to this:
Set LastR = .Range("a" & Rows.Count).End(xlUp).Offset(2,0)

Regards,
Rory

[eran3185]

sorry rory , but i get the worksheet one on another , and i want them first-empty line-second-empty line etc ...

there is something that i miss ...

[rory]

What is your current code?

[eran3185]

Sub teset4()
Dim myDir As String, fn As String, a(), i As Integer, ws As Worksheet, LastR As Range

myDir = "C:\test\"
fn = Dir(myDir & "book1*.xls")
Do While fn <> ""

With Workbooks.Open(myDir & fn)
With ThisWorkbook.Sheets(1)
Set LastR = .Range("a1")
If Not IsEmpty(LastR) Then _
Set LastR = .Range("a" & Rows.Count).End(xlUp).Offset(2, 0)
End With
With .Sheets("7.07").UsedRange
LastR.Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
.Close False
End With
fn = Dir()
loop
end sub

[rory]

Do you always have data in every row of column A in the worksheets you are copying from?
Regards,
Rory

[eran3185]

i think so.
why ?

[Simon Lloyd]

Cross posted 11:15 today Here

[rory]

Because that code should work unless you are missing data in the last row of column A.
Regards,
Rory

[eran3185]

maybe something there is not right.
i think that if i will change 1-2 lines in the code - that will be 100%.
the problem is that the second file will cover on the first etc ...
i want that they will copy one above another

[rory]

Does this work for you:
[VBA]Sub teset4()
Dim myDir As String, fn As String, a(), i As Integer, ws As Worksheet, LastR As Range

myDir = "C:\test\"
fn = Dir(myDir & "book1*.xls")
Do While fn <> ""

With Workbooks.Open(myDir & fn)
With ThisWorkbook.Sheets(1)
Set LastR = .Range("a1")
If Not IsEmpty(LastR) Then _
Set LastR = .Cells(LastCellInSheet(ThisWorkbook.Sheets(1)).Row + 2, "A")
End With
With .Sheets("7.07").UsedRange
LastR.Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
.Close False
End With
fn = Dir()
Loop
End Sub
Public Function LastCellInSheet(wks As Worksheet) As Range
' Returns the cell at the bottom right corner of the sheet's real used range
Dim lngLastCol As Long, lngLastRow As Long
lngLastCol = 1
lngLastRow = 1
On Error Resume Next
With wks.UsedRange
lngLastCol = .Cells.Find(what:="*", after:=.Cells(1), _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
lngLastRow = .Cells.Find(what:="*", after:=.Cells(1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End With
Set LastCellInSheet = wks.Cells(lngLastRow, lngLastCol)
End Function
[/VBA]

Regards,
Rory

[eran3185]

rory - many many thenks , but maybe i didnt explain well :
i have some files : book1 , book11 , book111
in all file i have worksheet called : 7.07
i want that in the "big" i have like this :

worksheet 7.07 - book1
worksheet 7.07 - book11
worksheet 7.07 - book111

i want to see all the worksheets from all the files
now i can see only the last file (because they are one on another)

[rory]

I'm still not sure if I understand you but is this what you want:

[VBA]

Sub teset4()
Dim myDir As String, fn As String, a(), i As Integer, ws As Worksheet, LastR As Range

myDir = "C:\test\"
fn = Dir(myDir & "book1*.xls")
Do While fn <> ""

With Workbooks.Open(myDir & fn)
With ThisWorkbook.Sheets(1)
Set LastR = .Cells(LastCellInSheet(ThisWorkbook.Sheets(1)).Row + 2, "A")
End With
With .Sheets("7.07").UsedRange
LastR.Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
.Close False
End With
fn = Dir()
Loop
End Sub
Public Function LastCellInSheet(wks As Worksheet) As Range
' Returns the cell at the bottom right corner of the sheet's real used range
Dim lngLastCol As Long, lngLastRow As Long
lngLastCol = 1
lngLastRow = 1
On Error Resume Next
With wks.UsedRange
lngLastCol = .Cells.Find(what:="*", after:=.Cells(1), _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
lngLastRow = .Cells.Find(what:="*", after:=.Cells(1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End With
Set LastCellInSheet = wks.Cells(lngLastRow, lngLastCol)
End Function

[/VBA]

If not, then you will have to post a sample of your workbooks and what you want in the 'Big' workbook.

Regards,
Rory

[Simon Lloyd]

This will copy sheets from all workbooks in a specified directory or folder (i say will i didn't test it!)
[VBA]
Sub CopySheets()
Dim Master As Workbook
Dim i As Integer
Dim sh As Worksheet
application.screenupdating=false
Set Master = ThisWorkbook
With Application.FileSearch
.NewSearch
.Filename = "*.xls"
.LookIn = "C:\Documents and Settings\Eran3185\My Documents\"'Change to suit
.SearchSubFolders = True
.Execute
For i = 1 To .FoundFiles.Count

Workbooks.Open .FoundFiles(i)
On Err GoTo ContEx
Sheets("7.07").Activate
ActiveWorkbook.Sheets("7.07").UsedRange.Copy
Master.Sheets(1).Range("A65536").End(xlUp).Offset(1).PasteSpecial
ActiveWorkbook.Close true
ContEx:
Next
End With
application.screenupdating=true
End Sub

[/VBA]