PDA

View Full Version : problem with a macro



eran3185
08-05-2007, 11:08 PM
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
08-05-2007, 11:45 PM
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

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
Perhaps declaring thisworkbook (your original) will work

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
Just a thought!

eran3185
08-05-2007, 11:52 PM
hey simon
it open me some files
i want to see all worksheets in one file only

rory
08-06-2007, 12:25 AM
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:
With Workbooks.Open(myDir & fn)
.Sheets("7.07").Copy

You need something like this (assuming you want to copy to the workbook containing the code):
With Workbooks.Open(myDir & fn)
.Sheets("7.07").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)


HTH
Rory

eran3185
08-06-2007, 12:38 AM
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
08-06-2007, 12:52 AM
Then you don't want to copy the sheet at all. Try this:
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

eran3185
08-06-2007, 02:34 AM
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
08-06-2007, 02:40 AM
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
08-06-2007, 02:49 AM
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
08-06-2007, 03:14 AM
What is your current code?

eran3185
08-06-2007, 03:17 AM
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
08-06-2007, 03:26 AM
Do you always have data in every row of column A in the worksheets you are copying from?
Regards,
Rory

eran3185
08-06-2007, 03:39 AM
i think so.
why ?

Simon Lloyd
08-06-2007, 03:59 AM
Cross posted 11:15 today Here (http://www.excelforum.com/showthread.php?p=1812588&posted=1#post1812588)

rory
08-06-2007, 04:50 AM
Because that code should work unless you are missing data in the last row of column A.
Regards,
Rory

eran3185
08-06-2007, 05:34 AM
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
08-06-2007, 05:42 AM
Does this work for you:
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


Regards,
Rory

eran3185
08-06-2007, 05:52 AM
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
08-06-2007, 06:00 AM
I'm still not sure if I understand you but is this what you want:



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



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
08-06-2007, 06:25 AM
This will copy sheets from all workbooks in a specified directory or folder (i say will i didn't test it!)

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

eran3185
08-06-2007, 07:27 AM
i think it's good !!!
many thenks , like always - you help me a-lot ...

eran :hi: