PDA

View Full Version : [SOLVED] Selected row--->other workbook?



erin64
02-03-2005, 01:48 AM
Hi U there!

Probably a stupid question and a simple answer, but for me it's all new... I tried to look but.....

I know there is some kind of way to link one cell from workbook1 to workbook 2.
But how it is done? The cells don't have the same position in both workbooks and I don't need to copy all the information.

Is there a way after linking these too togeher, to make a command button and put some kind of a macro attached to it? So that everytime one selects a row the information copies into woorkbook and then prints it..? Dont have to save the document but I do need 6 prints of the workbook2? Then selecting another row in workbook1 and doing the same all over again...:doh:

If something like this exists, it would help my work tremendously... Now I am adding the information manually by copying and pasting and printing...
You can imagine I do this about to 80-100 rows a day, 6 copies of each, about 20 cells to link....

So any help is more than wellcomed,

-erin-

Jacob Hilderbrand
02-03-2005, 02:12 AM
Try this to get you started. It will copy the active row to a new workbook. If you want to do this for a certain number of rows automatically we can do that too (i.e., copy rows 1-100 seperately to a new workbook and print 6 copies each).


Option Explicit

Sub CopyAndPrint()
Dim Wkb As Workbook
Application.ScreenUpdating = False
ActiveCell.EntireRow.Copy
Set Wkb = Workbooks.Add
ActiveSheet.Paste
Wkb.Sheets("Sheet1").PrintOut Copies:=6
Wkb.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub

erin64
02-03-2005, 02:54 AM
Thanks for the quick answer, I knew I could count on You all...


But couple of ?s before I even try...

How does it knov which excel workbooks and sheets are in question? And how does it know that in

Asiakkaat.xls|sheet1|A1 goes to Veroinsiirto.xls|Sheet1|B2

and next piece of needed information is

Asiakkaat.xls|sheet1|D1 goes to Veroinsiirto.xls|Sheet1|G10


Any help?


-erin- embarassed:mkay

Jacob Hilderbrand
02-03-2005, 03:16 AM
We can specify the workbooks and sheets, but you need to let me know a bit more so I know where the data is going.

So you have a cell in Row 1 selected and run the macro.
A1 is copied to B2 in a second workbook.
D1 is copied to G10 in a second workbook.

Why is the data going there? Does it always go to the same place in the workbook and overwrite the old data or does it actually go to the next available row?

erin64
02-03-2005, 03:46 AM
Hi again, You are a life saver:)

The sheet 2 has a form that is reguired by authoroties in 6 copies. The data always goes to same places and it doesn't have to save it....
It would help to be able to select multiple rows and then let the machine do the rest...

We are collecting customer data and every now and then (tens of times a day) move all the changed data to sheet 1 which is also cleared after moving the data to the forms and copied *6.

Any clearer? Sorry my bad english... and uncleariness

thanks -erin-

erin64
02-03-2005, 03:54 AM
So I open both workbooks, select a row1. Then start recording the macro? Select A1,ctrl C, go to workbook2, select B2,ctrl V,then click go back to workbook1 and do the same D1 and the rest of stuff?

And with that piece of code it knows where to but A333??? Wauuu!:wot

Jacob Hilderbrand
02-03-2005, 04:02 AM
Put this code in Asiakkaat.xls and make sure both workbooks are opened.


Option Explicit

Sub CopyAndPrint()
Dim Wkb As Workbook
Dim WS As Worksheet
Dim TotalRows As Long
Dim i As Long
Dim StartRow As Long
Application.ScreenUpdating = False
TotalRows = Selection.Rows.Count
StartRow = Selection(1, 1).Row
Set Wkb = Workbooks("Veroinsiirto.xls")
Set WS = Wkb.Sheets("Sheet1")
For i = StartRow To StartRow + TotalRows - 1
WS.Range("B2").Value = _
ThisWorkbook.Sheets("Sheet1").Range("A1").Value
WS.Range("G10").Value = _
ThisWorkbook.Sheets("Sheet1").Range("D1").Value
WS.PrintOut Copies:=6
Next i
Wkb.Close SaveChanges:=False
Application.ScreenUpdating = True
Set WS = Nothing
Set Wkb = Nothing
End Sub

erin64
02-03-2005, 07:13 AM
Hi there, it's me bothering again:wot

I wrote it. Put the cells and changed the names and so on. I copied the code into into Sheet Temp (actually sheet2, but named later as Temp.) I try to run the code with F8, it stops and says: Runtime error '9': subscript out of range..
Whatever that means...
I probably understood something wrong, because it doesn't work. Any idea?
I'll enclose the code here:


Option Explicit

Sub CopyAndPrint()
Dim Wkb As Workbook
Dim WS As Worksheet
Dim TotalRows As Long
Dim i As Long
Dim StartRow As Long
Application.ScreenUpdating = False
TotalRows = Selection.Rows.Count
StartRow = Selection(1, 1).Row
Set Wkb = Workbooks("Veroinsiirto.xls")
Set WS = Wkb.Sheets("Temp")
For i = StartRow To StartRow + TotalRows - 1
WS.Range("BB2").Value = _
ThisWorkbook.Sheets("Temp").Range("A2").Value
WS.Range("BB2").Value = _
ThisWorkbook.Sheets("Temp").Range("J2").Value
WS.Range("A2").Value = _
ThisWorkbook.Sheets("Temp").Range("A6").Value
WS.Range("B2").Value = _
ThisWorkbook.Sheets("Temp").Range("J6").Value
WS.Range("AO2").Value = _
ThisWorkbook.Sheets("Temp").Range("H8").Value
WS.Range("Z2").Value = _
ThisWorkbook.Sheets("Temp").Range("A16").Value
WS.Range("AZ2").Value = _
ThisWorkbook.Sheets("Temp").Range("J16").Value
WS.Range("AA2").Value = _
ThisWorkbook.Sheets("Temp").Range("M16").Value
WS.Range("BD2").Value = _
ThisWorkbook.Sheets("Temp").Range("A23").Value
WS.Range("BE2").Value = _
ThisWorkbook.Sheets("Temp").Range("J23").Value
WS.Range("BF2").Value = _
ThisWorkbook.Sheets("Temp").Range("M23").Value
WS.Range("AV2").Value = _
ThisWorkbook.Sheets("Temp").Range("D36").Value
WS.Range("AO2").Value = _
ThisWorkbook.Sheets("Temp").Range("D10").Value
WS.PrintOut Copies:=6
Next i
Wkb.Close SaveChanges:=False
Application.ScreenUpdating = True
Set WS = Nothing
Set Wkb = Nothing
End Sub

johnske
02-03-2005, 07:27 AM
Hi Erin,

'subscript out of range' generally means that the sheet or book that you're referencing either doesn't exist or, if it's a workbook, isn't open.

Make sure you have named the sheets and book EXACTLY as they appear in the code, any simple spelling mistake such as an extra space between two words or an added full-stop will cause that error message. Also, are both books open when you run the code? If not, that'll also generate the error message.

Regards,
John

johnske
02-03-2005, 07:31 AM
PS: With error messages it always help to click the "Debug" button and have a look at exactly what line of code is highlighted and let us know what line that is. (This gives us a clue as to where the error may be..)

Paleo
02-03-2005, 07:44 AM
Use:



Application.Workbooks.Add ("Veroinsiirto.xls")
TotalRows = Selection.Rows.Count
StartRow = Selection(1, 1).Row
Set Wkb = Workbooks("Veroinsiirto.xls")
Set WS = Wkb.Sheets("Temp")


at the beggining of your macro.

Paleo
02-03-2005, 07:48 AM
Dont forget the:



Application.Windows("Veroinsiirto.xls").Close


At the end of your macro, just before the "End Sub".

erin64
02-03-2005, 07:51 AM
Hi Johnske, You're probably right. I'll check it... Thanks for help.

And I'll be back with more stupid questions...:rotlaugh: ....

erin64
02-03-2005, 09:22 AM
Paleo, Thanks for your help, but I don't have a clue what are You talking about....:=0

erin64
02-03-2005, 09:36 AM
Still can't figure what's wrong...


StartRow = Selection(1, 1).Row

(does it matter, that in workbook1, sheet2, the row 1 is Titles???)

I'm turning grey overnight here, but am very happy that You have helped me so much:)

johnske
02-03-2005, 11:11 AM
Still can't figure what's wrong...

StartRow = Selection(1, 1).Row (does it matter, that in workbook1, sheet2, the row 1 is Titles???)

I'm turning grey overnight here, but am very happy that You have helped me so much:)
Hi erin,

Probably the best way to handle this is to zip a copy of what you've got and post it here (no need to include every entry that may have any sensitive data) so one of us can fix it for you and post it back.

(Go to manage attachments when you're posting, select your zip file, then click "upload" to include it in your post :) )

Paleo
02-03-2005, 11:23 AM
Erin,

you must open the file before using it. Try this code:



Option Explicit

Sub CopyAndPrint()
Dim Wkb As Workbook
Dim WS As Worksheet
Dim TotalRows As Long
Dim i As Long
Dim StartRow As Long
Application.ScreenUpdating = False
TotalRows = Selection.Rows.Count
StartRow = Selection(1, 1).Row
Application.Workbooks.Add ("Veroinsiirto.xls")
Set Wkb = Workbooks("Veroinsiirto.xls")
Set WS = Wkb.Sheets("Temp")
For i = StartRow To StartRow + TotalRows - 1
WS.Range("BB2").Value = _
ThisWorkbook.Sheets("Temp").Range("A2").Value
WS.Range("BB2").Value = _
ThisWorkbook.Sheets("Temp").Range("J2").Value
WS.Range("A2").Value = _
ThisWorkbook.Sheets("Temp").Range("A6").Value
WS.Range("B2").Value = _
ThisWorkbook.Sheets("Temp").Range("J6").Value
WS.Range("AO2").Value = _
ThisWorkbook.Sheets("Temp").Range("H8").Value
WS.Range("Z2").Value = _
ThisWorkbook.Sheets("Temp").Range("A16").Value
WS.Range("AZ2").Value = _
ThisWorkbook.Sheets("Temp").Range("J16").Value
WS.Range("AA2").Value = _
ThisWorkbook.Sheets("Temp").Range("M16").Value
WS.Range("BD2").Value = _
ThisWorkbook.Sheets("Temp").Range("A23").Value
WS.Range("BE2").Value = _
ThisWorkbook.Sheets("Temp").Range("J23").Value
WS.Range("BF2").Value = _
ThisWorkbook.Sheets("Temp").Range("M23").Value
WS.Range("AV2").Value = _
ThisWorkbook.Sheets("Temp").Range("D36").Value
WS.Range("AO2").Value = _
ThisWorkbook.Sheets("Temp").Range("D10").Value
WS.PrintOut Copies:=6
Next i
Wkb.Close SaveChanges:=False
Application.ScreenUpdating = True
Set WS = Nothing
Set Wkb = Nothing
Application.Windows("Veroinsiirto.xls").Close
End Sub

erin64
02-03-2005, 11:43 AM
Thanks Paleo,
Gives the same error ....:banghead:

I'll zip the files and send them here... There are other problems too if someone doesn't have anything else to do:rotlaugh: ... ( Private Sub Etsi_Click() should be prevented to search the temp sheet, or it never stops:( ), and the same sub saves the temp, shouldn't save the commandbuttons also...) I hope You don't die of laughter here, I just started January...

But this is the main thing and can't go further untill it works...

Anybody wants a beer, I sure could use one....:beerchug:

johnske
02-03-2005, 11:45 AM
Paleo, he already has a workbook "Veroinsiirto.xls", using this code you're giving >> Application.Workbooks.Add ("Veroinsiirto.xls") ... is adding a new book. i.e. a copy of Veroinsiirto.xls... If you want to open the existing book you should use something similar to this:


On Error Resume Next '<< error handling for if the book's already open
Application.Workbooks.Open(ActiveWorkbook.Path & "\Veroinsiirto.xls")
Workbooks("Veroinsiirto.xls").Activate

John

erin64
02-03-2005, 12:02 PM
The zip here, the first one was too large.
And by the way Johnske, it's she:hi:

johnske
02-03-2005, 12:10 PM
The zip here, the first one was too large.
And by the way Jonske, it's she:hi: :oops: sorry...

No, the attachment's not there, after you post it, have a look, (or maybe you can see it in "Preview Post") to see if you have a symbol there and some writing saying 'something or other' .zip

Paleo
02-03-2005, 12:28 PM
Hi John,

yes you right, I goofed. Well lets try with the file when she posts it...

johnske
02-03-2005, 12:36 PM
By the way erin,

I've had problems uploading attachments before, dont know the reason why, but at some times of the day it just cant be done yet if you try a few hours later it does it straight away :dunno

Oh well, it's well past :sleeping: :snooze :snore: time here in OZ :hi: ...later

Paleo
02-03-2005, 12:42 PM
By my calculations its about midnight there. Do you sleep so early?

Paleo
02-03-2005, 12:50 PM
Hi erin,

what am I expected to answer here?


Kirjoita nimi?

erin64
02-03-2005, 01:26 PM
It's search name, but it searches anything:)
:whistle: :rotlaugh:

erin64
02-03-2005, 03:14 PM
Hi, I was wondering where it figures out what is the other workbook. The target is Veroinsiirto and the source Ast.? Stubid ? again...

Jacob Hilderbrand
02-03-2005, 04:08 PM
Option Explicit

Sub CopyAndPrint()
Dim Wkb As Workbook
Dim WS As Worksheet
Dim TotalRows As Long
Dim i As Long
Dim StartRow As Long
Application.ScreenUpdating = False
TotalRows = Selection.Rows.Count
StartRow = Selection(1, 1).Row
Set Wkb = Workbooks("Veroinsiirto.xls")
Set WS = Wkb.Sheets("Taul2")
For i = StartRow To StartRow + TotalRows - 1
WS.Range("BB2").Value = _
ThisWorkbook.Sheets("Temp").Range("A2").Value
WS.Range("BB2").Value = _
ThisWorkbook.Sheets("Temp").Range("J2").Value
WS.Range("A2").Value = _
ThisWorkbook.Sheets("Temp").Range("A6").Value
WS.Range("B2").Value = _
ThisWorkbook.Sheets("Temp").Range("J6").Value
WS.Range("AO2").Value = _
ThisWorkbook.Sheets("Temp").Range("H8").Value
WS.Range("Z2").Value = _
ThisWorkbook.Sheets("Temp").Range("A16").Value
WS.Range("AZ2").Value = _
ThisWorkbook.Sheets("Temp").Range("J16").Value
WS.Range("AA2").Value = _
ThisWorkbook.Sheets("Temp").Range("M16").Value
WS.Range("BD2").Value = _
ThisWorkbook.Sheets("Temp").Range("A23").Value
WS.Range("BE2").Value = _
ThisWorkbook.Sheets("Temp").Range("J23").Value
WS.Range("BF2").Value = _
ThisWorkbook.Sheets("Temp").Range("M23").Value
WS.Range("AV2").Value = _
ThisWorkbook.Sheets("Temp").Range("D36").Value
WS.Range("AO2").Value = _
ThisWorkbook.Sheets("Temp").Range("D10").Value
WS.PrintOut Copies:=6
Next i
Wkb.Close SaveChanges:=False
Application.ScreenUpdating = True
Set WS = Nothing
Set Wkb = Nothing
End Sub

WS is the sheet you want to fill out in Veroinsiirto.xls.
ThisWorkbook.Sheets("Temp") is the sheet you want to get the data from.

Richie(UK)
02-03-2005, 04:09 PM
For reference only, see also:

http://www.ozgrid.com/forum/showthread.php?p=148662#post148662

Jacob Hilderbrand
02-03-2005, 04:13 PM
Hi, I was wondering where it figures out what is the other workbook. The target is Veroinsiirto and the source Ast.? Stubid ? again...


Set Wkb = Workbooks("Veroinsiirto.xls")

Wkb is now set to the other Workbook.

erin64
02-03-2005, 04:33 PM
Thanks for help, actually I figured with somebody out that the sheet1in Veroinsiirto was named Taul2, changed that, starts printing the right sheet, but no data added and prints thousands of thousands copies...
Gives an error report Run-time error 1004, Method Print out of object..worksheet failed?:banghead: :banghead:

johnske
02-03-2005, 04:43 PM
For a start, move this line after
Next i

WS.PrintOut Copies:=6

Jacob Hilderbrand
02-03-2005, 04:48 PM
WS.Range("A2").Value = _
ThisWorkbook.Sheets("Temp").Range("A6").Value
This is taking the data from Temp. In your attachment Temp has no data.

johnske
02-03-2005, 04:50 PM
Next, you have TWO things that are being put into BB2 and AO2, the second of each would over-write the first. There may be more errors as well, but I'm not going to look at the lot right now....

erin64
02-03-2005, 05:07 PM
Hi U all, you are so dears..

First of all I changed the printing line, and AO2 is needed in two different places in the target sheet...Problem?

And temp will have information when You run the other code and find customers info and change it...

Next?:rofl

It's two o'clock here and I've been waken since 6 this morning... Been gazing this code most of the time, will go to school 8 o'clock:wot :think: :whip

Jacob Hilderbrand
02-03-2005, 05:18 PM
You can put AO2 in as many places as you want. But I believe you have it backwards in the code.

Range(Range Where Data Is Going) = Range(Range Where Data Is From)


WS.Range("AO2").Value = _
ThisWorkbook.Sheets("Temp").Range("D10").Value

This means change the value in WS.Range("AO2") so that it is equal to the value in Sheets("Temp").Range("D10")

Do you mean to do this?


WS.Range("D10").Value = _
ThisWorkbook.Sheets("Temp").Range("AO2").Value

erin64
02-03-2005, 05:29 PM
Yes, from ao2-d10, going to change that but it doesn't solve the problem does it?

erin64
02-03-2005, 05:40 PM
Changed and now run time error 1004, application defined or object defined???

It looks like this nowadays:wot


Sub CopyAndPrint()
Dim Wkb As Workbook
Dim WS As Worksheet
Dim TotalRows As Long
Dim i As Long
Dim StartRow As Long
Application.ScreenUpdating = False
TotalRows = Selection.Rows.Count
StartRow = Selection(1, 1).Row
Application.Workbooks.Add ("Veroinsiirto.xls")
Set Wkb = Workbooks("Veroinsiirto.xls")
Set WS = Wkb.Sheets("Temp")
For i = StartRow To StartRow + TotalRows - 1
WS.Range("A2").Value = _
ThisWorkbook.Sheets("Temp").Range("BB2").Value
WS.Range("J2").Value = _
ThisWorkbook.Sheets("Temp").Range("BB2").Value
WS.Range("BB2").Value = _
ThisWorkbook.Sheets("Temp").Range("A2").Value
WS.Range("J6").Value = _
ThisWorkbook.Sheets("Temp").Range("B2").Value
WS.Range("H8").Value = _
ThisWorkbook.Sheets("Temp").Range("AO2").Value
WS.Range("A16").Value = _
ThisWorkbook.Sheets("Temp").Range("Z2").Value
WS.Range("J16").Value = _
ThisWorkbook.Sheets("Temp").Range("AZ2").Value
WS.Range("").Value = _
ThisWorkbook.Sheets("Temp").Range("AA2").Value
WS.Range("A23").Value = _
ThisWorkbook.Sheets("Temp").Range("BD2").Value
WS.Range("").Value = _
ThisWorkbook.Sheets("Temp").Range("BE2").Value
WS.Range("M23").Value = _
ThisWorkbook.Sheets("Temp").Range("BF2").Value
WS.Range("D36").Value = _
ThisWorkbook.Sheets("Temp").Range("AV2").Value
WS.Range("D10").Value = _
ThisWorkbook.Sheets("Temp").Range("AO2").Value
Next i
WS.PrintOut Copies:=6
Wkb.Close SaveChanges:=False
Application.ScreenUpdating = True
Set WS = Nothing
Set Wkb = Nothing
Application.Windows("Veroinsiirto.xls").Close
End Sub

johnske
02-03-2005, 05:43 PM
This might be easier to read and sort out what needs to go where, and, reading back thru the earier posts I see you do want printout inside the loop. Try putting some data into temp:


Sub CopyAndPrint()
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisBook
Dim i As Long
Set Wkb = Workbooks("Veroinsiirto.xls")
Set WS = Wkb.Sheets("Taul2")
Set ThisBook = ThisWorkbook.Sheets("Temp")
Application.ScreenUpdating = False
For i = Selection(1, 1).Row To Selection(1, 1). _
Row + Selection.Rows.Count - 1
'Going TO HERE <<<<<< FROM HERE
WS.Range("AO2") = ThisBook.Range("H8")
WS.Range("AO2") = ThisBook.Range("D10")
WS.Range("BB2") = ThisBook.Range("A2")
WS.Range("BB2") = ThisBook.Range("J2")
WS.Range("A2") = ThisBook.Range("A6")
WS.Range("B2") = ThisBook.Range("J6")
WS.Range("Z2") = ThisBook.Range("A16")
WS.Range("AZ2") = ThisBook.Range("J16")
WS.Range("AA2") = ThisBook.Range("M16")
WS.Range("BD2") = ThisBook.Range("A23")
WS.Range("BE2") = ThisBook.Range("J23")
WS.Range("BF2") = ThisBook.Range("M23")
WS.Range("AV2") = ThisBook.Range("D36")
WS.PrintOut Copies:=6
Next i
Wkb.Close SaveChanges:=False
Set WS = Nothing
Set Wkb = Nothing
Set ThisBook = Nothing
End Sub

erin64
02-03-2005, 11:03 PM
Hi there,

Now it prints allright, but no data added....


Is this always like this, after one problem solved, next jumps in???:think: :doh: :banghead:

erin64
02-03-2005, 11:39 PM
Chee Johnske!!!!
It looks like it works!!!!!! Let me check!!! It seems I run out of black ink, that's why...:mkay I'll check it...

First problem I noticed, it will print 1 copy but 6 sheets... How to put that there?? Allways a new problem....

I have another stupid ? again...

Is there a way to but this code not to searh the Temp, it gets searching and searcing again... (loop?):wot


Private Sub CommandButton1_Click()
Dim oSheet As Object
Dim Firstcell As Range
Dim NextCell As Range
Dim WhatToFind As Variant
Dim rCopyCells As Range
On Error GoTo Err
Application.ScreenUpdating = False
Sheets("Temp").Select
Range("B2:B50").Select
Selection.ClearContents
Sheets("Vero").Select
Application.ScreenUpdating = True
WhatToFind = Application.InputBox("Search!", "Etsi", , 100, 100, , , 2)
If WhatToFind = False Then
Sheets("Vero").Select
End
End If
If WhatToFind <> "" And Not WhatToFind = False Then
For Each oSheet In ActiveWorkbook.Worksheets
oSheet.Activate
oSheet.[a1].Activate
Set Firstcell = Cells.Find(What:=WhatToFind, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not Firstcell Is Nothing Then
Firstcell.Activate
If MsgBox("Add Record", vbInformation + vbYesNo) = vbYes Then
ActiveCell.Select
Selection.EntireRow.Copy Destination:= _
Sheets("Temp").Range("A65536").End(xlUp).Offset(1, 0)
Set rCopyCells = Nothing
End If
On Error Resume Next
While (Not NextCell Is Nothing) And (Not NextCell.Address = Firstcell.Address)
Set NextCell = Cells.FindNext(After:=ActiveCell)
If Not NextCell.Address = Firstcell.Address Then
NextCell.Activate
If MsgBox("Add Record", vbInformation + vbYesNo) = vbYes Then
ActiveCell.Select
Selection.EntireRow.Copy Destination:= _
Sheets("Temp").Range("A65536").End(xlUp).Offset(1, 0)
End If
End If
Wend
End If
Set NextCell = Nothing
Set Firstcell = Nothing
Next oSheet
End If
Application.ScreenUpdating = False
Sheets("Temp").Select
Range("A2,AA1300").Select
Application.ScreenUpdating = True
Sheets("Vero").Select
Sheets("Temp").Copy
End
Err:
MsgBox "An error!Try again!!"
End
End Sub

johnske
02-04-2005, 01:55 AM
Hi erin,

1st things 1st... If you look at the destination for your data you'll see that you have data going to Range("BF2").

Now, Go to sheet "Taul2". If you look at this sheet in "Page Break Preview" (Go to "View" and select "Page Break Preview"), the blue lines that mark out the page area that will be printed extend out to column BF (which is exactly where you've said the data is to go to) and this is also marked as "page 6" in page break preview.

You need to sort out the destination (in the code module) so that the data goes only to the fields that are marked out on Page 1.

I dont know exactly what's going from where to where as the headings on Page 1 of Taul2 are 1) not in english and 2) the sheet that the data is coming from has no data on it anyway. So I'm unable to say "Oh yes, that's their 1st name, that should be going to there, and that's their 2nd name and that should be going here" - so, sorry, you will have to sort that out yourself...
:think:

johnske
02-04-2005, 02:30 AM
Now, I'm only guessing here, but I think you may have the source and destination completely reversed, but, as I said, you (or someone else that can read your language) are the only one that can check if this is correct...Try this:


Sub CopyAndPrint()
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisBook
Dim i As Long
Set Wkb = Workbooks("Veroinsiirto.xls")
Set WS = Wkb.Sheets("Taul2")
Set ThisBook = ThisWorkbook.Sheets("Sheet1")
Application.ScreenUpdating = False
WS.Range("R1:BD2").ClearContents 'only need this once
For i = Selection(1, 1).Row To Selection(1, 1).Row + Selection.Rows.Count - 1
'DESTINATION SOURCE
WS.Range("H8") = ThisBook.Range("AO2")
WS.Range("D10") = ThisBook.Range("AO2")
WS.Range("A2") = ThisBook.Range("BB2")
WS.Range("J2") = ThisBook.Range("BB2")
WS.Range("A6") = ThisBook.Range("A2")
WS.Range("J6") = ThisBook.Range("B2")
WS.Range("A16") = ThisBook.Range("Z2")
WS.Range("J16") = ThisBook.Range("AZ2")
WS.Range("M16") = ThisBook.Range("AA2")
WS.Range("A23") = ThisBook.Range("BD2")
WS.Range("J23") = ThisBook.Range("BE2")
WS.Range("M23") = ThisBook.Range("BF2")
WS.Range("D36") = ThisBook.Range("AV2")
WS.PrintOut copies:=6
Next i
Wkb.Close SaveChanges:=False
Set WS = Nothing
Set Wkb = Nothing
Set ThisBook = Nothing
End Sub

Note, also, before trying this, go to the sheet "Taul2" and drag the Bottom Border of the page break preview 2 rows down and save.

erin64
02-04-2005, 03:42 AM
YES!!!!
Except it doesn't print anymore all the rows, only the first one....

THANKS and KIsses!!!:bow:

johnske
02-04-2005, 04:09 AM
YES!!!!
Except it doesn't print anymore all the rows, only the first one....

THANKS and KIsses!!!:bow:You mean only the first row from the source? It still prints the page Taul2 doesn't it?

erin64
02-04-2005, 04:34 AM
Yes it prints the right part of the right sheet on the right workbook with right data on it:beerchug: ,

but only the first row from the target... all the data from source is in it..



edit:
I'll put the accurate code here, it's easier to see what I've messed again:


Sub SearchandCopy()
Dim oSheet As Object
Dim Firstcell As Range
Dim NextCell As Range
Dim WhatToFind As Variant
Dim rCopyCells As Range
On Error GoTo Err
Application.ScreenUpdating = False
Sheets("Temp").Select
Range("A2:D1000").Select
Selection.ClearContents
Sheets("Vero").Select
Application.ScreenUpdating = True
WhatToFind = Application.InputBox("Kirjoita nimi?", "Etsi", , 100, 100, , , 2)
If WhatToFind = False Then
Sheets("Vero").Select
End
End If
If WhatToFind <> "" And Not WhatToFind = False Then
For Each oSheet In ActiveWorkbook.Worksheets
oSheet.Activate
oSheet.[a1].Activate
Set Firstcell = Cells.Find(What:=WhatToFind, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not Firstcell Is Nothing Then
Firstcell.Activate
If MsgBox("Add Record", vbInformation + vbYesNo) = vbYes Then
ActiveCell.Select
Selection.EntireRow.Copy Destination:= _
Sheets("Temp").Range("A65536").End(xlUp).Offset(1, 0)
Set rCopyCells = Nothing
End If
On Error Resume Next
While (Not NextCell Is Nothing) And (Not NextCell.Address = Firstcell.Address)
Set NextCell = Cells.FindNext(After:=ActiveCell)
If Not NextCell.Address = Firstcell.Address Then
NextCell.Activate
If MsgBox("Add Record", vbInformation + vbYesNo) = vbYes Then
ActiveCell.Select
Selection.EntireRow.Copy Destination:= _
Sheets("Temp").Range("A65536").End(xlUp).Offset(1, 0)
End If
End If
Wend
End If
Set NextCell = Nothing
Set Firstcell = Nothing
Next oSheet
End If
Application.ScreenUpdating = False
Sheets("Temp").Select
Range("A2,AA1300").Select
Application.ScreenUpdating = True
Sheets("Vero").Select
Sheets("Temp").Copy
End
Err:
MsgBox "Sorry, virhe. Yrit? uudelleen!"
End
End Sub

johnske
02-04-2005, 04:43 AM
Yes it prints the right part of the right sheet oh the right workbook with right data on it:beerchug: ,

but only the first row from the target... all the data from source is in it..

OK, seeing we've established that all the source data starts from row 2, try this variation:


Sub CopyAndPrint()
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisBook
Dim i As Long
Set Wkb = Workbooks("Veroinsiirto.xls")
Set WS = Wkb.Sheets("Taul2")
Set ThisBook = ThisWorkbook.Sheets("Sheet1")
Application.ScreenUpdating = False
WS.Range("R1:BD2").ClearContents
i = 2
Do Until ActiveCell = Empty
Range("A" & i).Select '< need something in A2 (at least)
'DESTINATION SOURCE
WS.Range("A6") = ThisBook.Range("A" & i)
WS.Range("J6") = ThisBook.Range("B" & i)
WS.Range("A16") = ThisBook.Range("Z" & i)
WS.Range("M16") = ThisBook.Range("AA" & i)
WS.Range("H8") = ThisBook.Range("AO" & i)
WS.Range("D10") = ThisBook.Range("AO" & i)
WS.Range("D36") = ThisBook.Range("AV" & i)
WS.Range("J16") = ThisBook.Range("AZ" & i)
WS.Range("A2") = ThisBook.Range("BB" & i)
WS.Range("J2") = ThisBook.Range("BB" & i)
WS.Range("A23") = ThisBook.Range("BD" & i)
WS.Range("J23") = ThisBook.Range("BE" & i)
WS.Range("M23") = ThisBook.Range("BF" & i)
WS.PrintOut copies:=6
i = i + 1
Loop
Wkb.Close SaveChanges:=False
Set WS = Nothing
Set Wkb = Nothing
Set ThisBook = Nothing
End Sub

johnske
02-04-2005, 04:52 AM
OOPS! Sorry did that too fast, change Range("A" & i).Select '< need something in A2 (at least)

to:ThisBook.Range("A" & i).Select '< need something in A2 (at least)

johnske
02-04-2005, 05:32 AM
From the other piece code you gave, I'm not entirely sure what the intent is... but I assume that once a name is found and one thing is done you don't want to do anything else with that name and you want to go on to the next name and not keep looping.

let me know whether this is doing what you intend to do, if not, it can be easily modified to do it:


Sub Button1_Click()
Dim oSheet As Object
Dim FindName As Range
Dim NextCell As Range
Dim NameToFind As Variant
Dim rCopyCells As Range
Dim Addit As Variant
On Error GoTo Err
Application.ScreenUpdating = False
Sheets("Temp").Select
Range("A2:D1000").Select
Selection.ClearContents
Sheets("Vero").Select
Application.ScreenUpdating = True
NameToFind = Application.InputBox("Kirjoita nimi?", "Etsi", , 100, 100, , , 2)
If NameToFind = Empty Then
Sheets("Vero").Select
End
End If
If NameToFind <> Empty Then
For Each oSheet In ActiveWorkbook.Worksheets
oSheet.Activate
oSheet.Range("A1").Activate
Set FindName = Cells.Find(What:=NameToFind, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If FindName Is Nothing Then
GoTo Err
Else
FindName.Activate
Addit = MsgBox("Add Record?", vbInformation + vbYesNo)
If Addit = vbYes Then
ActiveCell.Select
Selection.EntireRow.Copy Destination:= _
Sheets("Temp").Range("A65536").End(xlUp).Offset(1, 0)
Exit Sub
End If
On Error Resume Next
Set NextCell = Cells.FindNext(After:=ActiveCell)
Do
NextCell.Activate
Addit = MsgBox("Add Record?", vbInformation + vbYesNo)
If Addit = vbYes Then
Selection.EntireRow.Copy Destination:= _
Sheets("Temp").Range("A65536").End(xlUp).Offset(1, 0)
Exit Sub
End If
Loop Until NextCell Is Nothing Or NextCell.Address = FindName.Address
End If
Set NextCell = Nothing
Set FindName = Nothing
Next oSheet
End If
Application.ScreenUpdating = False
Sheets("Temp").Select
Range("A2,AA1300").Select
Application.ScreenUpdating = True
Sheets("Vero").Select
Sheets("Temp").Copy
End
Err:
MsgBox "Sorry, virhe. Yrit? uudelleen!"
End
End Sub

johnske
02-04-2005, 05:49 AM
From the other piece code you gave, I'm not entirely sure what the intent is... but I assume that once a name is found and one thing is done you don't want to do anything else with that name and you want to go on to the next name and not keep looping.

By that I mean that I'm assuming that there's only one entry for each person, right? Or may there be more than one entry? (PS: what I gave could probably also be cleaned up some more)

erin64
02-04-2005, 08:05 AM
Hi there, can't try it now, but the meaning is that you enter the name, the alien searches the whole column Z at Sheet1, user can accept, or deny the selection, if added, it stores it into Temp sheet. Temp will be saved and printedor sometimes added to another workbook sometimes, but not allways. The temp can be cleared...

Thanks for working this puzzle out with me:friends:

-erin-

johnske
02-04-2005, 09:09 AM
Hi erin,

Up till now I haven't been able to properly test what I've given you cause my printer had problems. I just got it going...

There were a couple of issues that've been sorted out now in the new code below.

Also, I added something....I assume once you have printed the 6 copies, you have no further need of the names on Sheet1, so now every time the printing is finished for each row, that row is deleted (otherwise those names would be re-printed each time you ran this):


Sub CopyAndPrint()
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisBook
Dim i As Long
Set Wkb = Workbooks("Veroinsiirto.xls")
Set WS = Wkb.Sheets("Taul2")
Set ThisBook = ThisWorkbook.Sheets("Sheet1")
Application.ScreenUpdating = False
i = 2
Do
ThisBook.Range("A" & i).Select
'DESTINATION SOURCE
WS.Range("A6") = ThisBook.Range("A" & i)
WS.Range("J6") = ThisBook.Range("B" & i)
WS.Range("A16") = ThisBook.Range("Z" & i)
WS.Range("M16") = ThisBook.Range("AA" & i)
WS.Range("H8") = ThisBook.Range("AO" & i)
WS.Range("D10") = ThisBook.Range("AO" & i)
WS.Range("D36") = ThisBook.Range("AV" & i)
WS.Range("J16") = ThisBook.Range("AZ" & i)
WS.Range("A2") = ThisBook.Range("BB" & i)
WS.Range("J2") = ThisBook.Range("BB" & i)
WS.Range("A23") = ThisBook.Range("BD" & i)
WS.Range("J23") = ThisBook.Range("BE" & i)
WS.Range("M23") = ThisBook.Range("BF" & i)
WS.PrintOut copies:=6
ActiveCell.Rows.EntireRow.ClearContents
ActiveCell.Offset(1, 0).Select
i = i + 1
Loop Until ActiveCell = Empty
Wkb.Close SaveChanges:=False
Set WS = Nothing
Set Wkb = Nothing
Set ThisBook = Nothing
End Sub
I'll be busy for about 12 hours so I won't be able to get to have a proper look at the other part till then...:beerchug:

johnske
02-04-2005, 07:22 PM
Hi erin,

Have a little time now, but first (have been reading back through the earliest posts) - some questions before I can get started, (I know English is not your 1st language, but please try to answer these as best you can)....

1) Is all your source data going to be on one sheet, i.e. the sheet "vero"?

2) I assume this source data on Vero is to be a permanent or semi-permanent record - correct?

3) Is there only one row of data on Vero relating to each persons name?

3) Do we really need to copy from a) the sheet Vero to the temp sheet, then b) from vero to sheet1, and then have to clear both vero and the temp sheet? - (I don't see that this is essential) - Could we not just transfer it to sheet1, print and clear each row one at a time till all have been done? OR
Do you need this other copy so you can refer to it and say "it's been done" which, it seems, is not what your other macro is doing at present (I'm asking this is because in your Button1_Click macro you have "Sheets("Temp").Select: Range("A2: D1000").ClearContents" - this clears the Temp sheet every time you look for a new name(?))

4) When we are searching Vero for data to be printed, what is the column we searching through for the data? (I assume this column would contain their primary, or "sur"-name).

5) When there are two or more people with the same primary name, how do you want to be able to determine which of these is the one you want to print?...we could do this several ways

A) List their primary name (and perhaps several other things that could uniquely identify them) in a message box asking if you want to add them to the list to be printed.... If you want to use other identifiers, which columns would they be in? - or

B) Probably not as good - we could select (highlight) the row that contains all their data



EDIT: Sorry that this is taking longer than it should erin, but, apart from simple language differences etc., your workbooks (that I'm working from) give error messages very frequently on things that are generally regarded as "good coding practice" and that will work instantly in another workbook. In addition, these error messages are not the "normal" type of error message that (usually) give you the option to debug - they're just message boxes with an error number in them.

I don't know why this is so :dunno whether it's a corrupt workbook (I doubt it) or because it's simply as different language version of office. In any case, I'm just trying to "work around it" - simply trying to find things that WILL work in your workbook.

This is probably why everyone has been having problems helping you... :)

John

erin64
02-05-2005, 02:03 AM
Hi John,

Sorry I haven't been able to answer earlier, but had to go to work yesterday, then my father had a hheart attack, so I was in hospital with him. No opening this thread made me almost cry to find out how much time and effort You are putting into solving this. Can't ever thank you enough!

Sorry about my english. It's bad and speaking about computer related issues don't make it better.:(

I'll explain the whole thing as simply as I can:

In workbook 1 I have three sheets. Worksheet1 and worksheet2(Vero) have customer registries.These two are identical in columns, but have different data. They may have same customers. And same customer may be many times in both sheet.


Column Z is customers name, but it can be in whatever mode(?). I mean there can be surname, second name and first name. Or just one of these. Can be written in capitals or not (not my fault: the register was bought by my boss so). But that is the only volumn that will identify the customer.

So now that we have found the customer, i need to pick the data conserning him,maybe add things or change it, add it to Temp(Sheet3). Then find next and so on. When I have all the customers I want in Temp, I need to but some of that information n workbook 2(Veroinsiirto). Then print 6 copies of each customer. I actually need that data in workbook1, Temp to be added in Workbook3 at the same shape it is in Temp, then I don't need it in Worbook1/Temp anymore. It can be cleared. Haven't been thinking the move in the Workbook3 yet.

I tried to run this in my working place yesterday and the search part went ok. Running the code CopyAndPrint() gave an error message Error in loading DLL.Error 48. And System Error &H8004005(-2147467259). What was that? Different version? The one I'm using is XP, at work I'm not sure, but I think 2000.

Starting to test your work now...

Thanks again, milllion times. You are an angel!

-erin-:hi:

johnske
02-05-2005, 02:36 AM
I tried to run this in my working place yesterday and the search part went ok. Running the code CopyAndPrint() gave an error message Error in loading DLL.Error 48. And System Error &H8004005(-2147467259). What was that? Different version? The one I'm using is XP, at work I'm not sure, but I think 2000.


Hi erin, really sorry to hear about your father, I hope he's on the mend now...

As for the last part, we really have to sort this out first... is CopyAndPrint running OK on your home computer, but not on the work computer? I have office 2000 running on Win98SE and its working perfectly on mine (only difference is I set the number of print copies to 1 instead of 6 to save ink :devil: )



PS: (Whether their name's in capitals or not doesn't present a problem)

erin64
02-05-2005, 03:12 AM
Hi there,
Just tested it at home.Does find the info ,put from one line prints hundreds of copies....
By the way, have You a MSN messenger?

erin64
02-05-2005, 03:16 AM
And it doesn't save the info in temp if I add a new customer... I was thinking to make all the addings at one click...
:eek: :think:

johnske
02-05-2005, 03:31 AM
And it doesn't save the info in temp if I add a new customer... I was thinking to make all the addings at one click...
:eek: :think:

OK, if you read my previous posting, that's what your code says to do, all I did with it was try to tidy it a bit and fixed it to get out of the infinite loop.

I have an idea that I've done a brief bit of code for that I'd like you to try, however, I'm now beginning to suspect your workbook may have become corrupted somewhere along the line.

No, I don't have Yahoo, I uninstalled it the other night. If you PM (private message) me your email address (click my name to PM me), I'll copy this code into a new workbook, zip it and email it and get you to try it in the new book to see if you're still having problems - if everything goes OK, we can then continue the thread on from there.

erin64
02-05-2005, 09:08 AM
Hi there!
With the great help of You all, I'm glad to be able to announce:Problem solved!

Especially I want to thank John for doing all the work for me!!!:bow: You are an angel! Thank You!:kiss

I'll be back with more problems!!!

-erin-:beerchug:

johnske
02-05-2005, 02:45 PM
Glad to hear that erin.

Do you know you can mark your thread Solved? Go to Thread tools to do that.

For those following this thread, one of the major hurdles appeared to be a corrupt workbook. The last code used (using actual emailed data & returned in an uncorrupted book by PM) was this:


Option Compare Text
Option Explicit

Sub Button1_Click()
Dim NameToFind As Variant
Dim Cell As Range
Dim Addit As VbMsgBoxResult
Dim AnyMore As VbMsgBoxResult
Dim Counter%
Sheets("Vero").Activate
Application.ScreenUpdating = False
NameToFind = Application.InputBox("Kirjoita nimi?", "Etsi", , 100, 100, , , 2)
If NameToFind = Empty Then
GoTo Finish
Else
Counter = 0
For Each Cell In Range("Z2:Z2000")
If Cell Like "*" & NameToFind & "*" Then '<< use "Like" for wildcards in If-Then statements
Addit = MsgBox("Add Record? ( " & Cell & " )", _
vbYesNo, "Is this record to be printed?")
Counter = Counter + 1
If Addit = vbYes Then
Cell.Select
Selection.EntireRow.Copy Destination:=Sheets _
("Sheet1").Range("A65536"). _
End(xlUp).Offset(1, 0)
End If
End If
Next Cell
End If
If Counter = 0 Then MsgBox "Sorry, no " & NameToFind & "s found", _
vbOKOnly, NameToFind & " Not Found"
AnyMore = MsgBox("Add more names?", vbYesNo, "Any More?")
If AnyMore = vbYes Then
Button1_Click
Else
Sheets("Sheet1").Activate
Application.ScreenUpdating = True
End If
Exit Sub
Finish:
MsgBox "sorry, no " & NameToFind & "s found", vbOKOnly, NameToFind & " Not Found"
Sheets("Temp").Activate
End Sub

'//This function by Joseph Ruben is used to find if a workbook's already open
Function WorkbookIsOpen(WorkBookName As String) As Boolean
'//Returns TRUE if the workbook is open
WorkbookIsOpen = False
On Error GoTo WorkbookIsNotOpen
If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
WorkbookIsOpen = True
Exit Function
End If
WorkbookIsNotOpen:
End Function[/vba][vba]Option Explicit

Sub CopyAndPrint()
Dim Wb As Workbook
Dim WS As Worksheet
Dim ThisBook
Dim i As Long
If WorkbookIsOpen("Veroinsiirto.xls") Then
Workbooks("Ast_07.xls").Activate
Else
Application.Workbooks.Open _
(ActiveWorkbook.Path & "\Veroinsiirto.xls")
Workbooks("Ast_07.xls").Activate
ActiveWorkbook.Sheets("Sheet1").Activate
DoEvents
End If
Set Wb = Workbooks("Veroinsiirto.xls")
Set WS = Wb.Sheets("Taul2")
Set ThisBook = ActiveWorkbook.Sheei = 2
Do
ThisBook.Range("A" & i).Select
'DESTINATION SOURCE
WS.Range("A6") = ThisBook.Range("A" & i)
WS.Range("J6") = ThisBook.Range("B" & i)
WS.Range("A16") = ThisBook.Range("Z" & i)
WS.Range("M16") = ThisBook.Range("AA" & i)
WS.Range("H8") = ThisBook.Range("AO" & i)
WS.Range("D10") = ThisBook.Range("AO" & i)
WS.Range("D36") = ThisBook.Range("AV" & i)
WS.Range("J16") = ThisBook.Range("AZ" & i)
WS.Range("A2") = ThisBook.Range("BB" & i)
WS.Range("J2") = ThisBook.Range("BB" & i)
WS.Range("A23") = ThisBook.Range("BD" & i)
WS.Range("J23") = ThisBook.Range("BE" & i)
WS.Range("M23") = ThisBook.Range("BF" & i)
WS.PrintOut copies:=6
ActiveCell.Rows.EntireRow.ClearContents
ActiveCell.Offset(1, 0).Select
i = i + 1
Loop Until ActiveCell = Empty
Wb.Close SaveChanges:=False
Set WS = Nothing
Set Wb = Nothing
Set ThisBook = Nothing
End Sub

johnske
02-06-2005, 03:28 AM
Hi erin,

Seeing that we've got this working, I've now cleaned up the code to get rid of a lot of redundant code and added a few comments so you can perhaps see what's going on and can change it to suit yourself.

Also, I have added a Cancel button to Button1_Click to get you out of the situation where you've found what you want to print but there may perhaps be hundreds more listings under the same name...

I dont think you'll have any problems with this, but to be on the safe side, make a copy of your current folder, delete the code in the copy and replace it with this and try it first...

PS: I'll leave it to you to change the english instructions on the message boxes to your own language :whistle:


Option Compare Text '<< this allows you to ignore upper & lower Cases
Option Explicit
Sub Button1_Click()
Dim NameToFind As Variant
Dim Cell As Range
Dim Addit As VbMsgBoxResult
Dim AnyMore As VbMsgBoxResult
Dim Counter%
Sheets("Vero").Activate
Application.ScreenUpdating = False
NameToFind = Application.InputBox("Kirjoita nimi?", "Etsi", , 100, 100, , , 2)
If NameToFind = Empty Then
Counter = 0
GoTo NotFound
Else
'counter is really only needed to test whether anything was found
Counter = 0
For Each Cell In Range("Z2:Z200")
'use "Like" for wildcards in If-Then statements
'for an exact match use If Cell = NameToFind Then
If Cell Like "*" & NameToFind & "*" Then
'a Cancel button has been added
Addit = MsgBox("Click Yes to print the record for " & Cell & vbLf & _
"" & vbLf & _
"Click No to look for the next record for " & NameToFind & vbLf & _
"" & vbLf & _
"Click Cancel if you want to start looking for another name", _
vbYesNoCancel, "IS THIS RECORD TO BE PRINTED? >> " & Cell)
Counter = Counter + 1
If Addit = vbYes Then
'copy this row to Sheet1 for printing
Cell.Select
Selection.EntireRow.Copy Destination:=Sheets _
("Sheet1").Range("A65536"). _
End(xlUp).Offset(1, 0)
'if Addit is vbNo it will simply look for the next match
'if Addit is vbCancel it will stop searching for this name
ElseIf Addit = vbCancel Then GoTo NeMore
End If
End If
Next Cell
End If
NotFound:
If Counter = 0 Then MsgBox "Sorry, no " & NameToFind & "s found", _
vbOKOnly, NameToFind & " Not Found"
NeMore:
AnyMore = MsgBox("Add more names?", vbYesNo, "Any More?")
If AnyMore = vbYes Then
Button1_Click
ElseIf Sheets("Sheet1").Range("A2") <> Empty Then
Sheets("Sheet1").Activate
Else: Sheets("Temp").Activate
End If
End Sub


'//This function is used to find if a workbook's already open
Function WorkbookIsOpen(WorkBookName As String) As Boolean
'//Returns TRUE if the workbook is open
WorkbookIsOpen = False
On Error GoTo WorkbookIsNotOpen
If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
WorkbookIsOpen = True
Exit Function
End If
WorkbookIsNotOpen:
End Function[/vba][vba]Option Explicit
Sub CopyAndPrint()
Dim Wb As Workbook
Dim WS As Worksheet
Dim i As Long
If WorkbookIsOpen("Veroinsiirto.xls") Then
Workbooks("Ast_07.xls").Activate
Else
Application.Workbooks.Open _
(ActiveWorkbook.Path & "\Veroinsiirto.xls")
Workbooks("Ast_07.xls").Activate
End If
'Ast_07.xls is now the activebook

Set Wb = Workbooks("Veroinsiirto.xls")
Set WS = Wb.Sheets("Taul2")
Application.ScreenUpdating = False

i = 2
Sheets("Sheet1").Activate
Range("A" & i).Activate
'unless stated otherwise, the remaining code
'now always refers to the given Range on Sheet1
Do
WS.Range("A6") = Range("A" & i)
WS.Range("J6") = Range("B" & i)
WS.Range("A16") = Range("Z" & i)
WS.Range("M16") = Range("AA" & i)
WS.Range("H8") = Range("AO" & i)
WS.Range("D10") = Range("AO" & i)
WS.Range("D36") = Range("AV" & i)
WS.Range("J16") = Range("AZ" & i)
WS.Range("A2") = Range("BB" & i)
WS.Range("J2") = Range("BB" & i)
WS.Range("A23") = Range("BD" & i)
WS.Range("J23") = Range("BE" & i)
WS.Range("M23") = Range("BF" & i)
WS.PrintOut copies:=6
'clear the last entry
ActiveCell.Rows.EntireRow.ClearContents
'select the next entry
ActiveCell.Offset(1, 0).Select
i = i + 1
Loop Until ActiveCell = Empty
Wb.Close SaveChanges:=False
Set WS = Nothing
Set Wb = Nothing