VBA-looping

[Anna314]

Hi

It is my first Excel related post ever but at this stage I'm desperate.
I've searched many websites and forums but can't find solution for the problem.

I have Command button in sheet 1 that is responsible for copying data from table in Sheet 2, pasting in specific cells in sheet 1 and printing Sheet 1.
Then it goes to the next row in Sheet 2, copying,pasting to Sheet 1 and printing Sheet1.
The problem is that it doesn't stop and prints empty cells too despite Do While Loop.
I tries CountA and Offset too but nothing works.

Option Explicit

Private Sub CommandButton1_Click()

Call DoWhile_Loop

End Sub


Sub DoWhile_Loop()

Dim BlankFound As Boolean
Dim x As Long

'Loop until a blank cell is found in Column A


Do While BlankFound = False
x = x + 1

If Cells(x, "A").Value = "" Then
BlankFound = True
End If



Worksheets("Sheet2").Range("A2").Copy
Worksheets("Sheet1").Range("B7").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("B2").Copy
Worksheets("Sheet1").Range("B11").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("C2").Copy
Worksheets("Sheet1").Range("D7").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("D2").Copy
Worksheets("Sheet1").Range("D3").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("E2").Copy
Worksheets("Sheet1").Range("D11").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("G2").Copy
Worksheets("Sheet1").Range("B3").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("F2").Copy
Worksheets("Sheet1").Range("B19").PasteSpecial Paste:=xlPasteFormulas
ActiveSheet.PrintOut


'After copying,paste printing row 2 in Sheet 2 it goes to next row in sheet 2:
Worksheets("Sheet2").Range("A3").Copy
Worksheets("Sheet1").Range("B7").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("B3").Copy
Worksheets("Sheet1").Range("B11").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("C3").Copy
Worksheets("Sheet1").Range("D7").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("D3").Copy
Worksheets("Sheet1").Range("D3").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("E3").Copy
Worksheets("Sheet1").Range("D11").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("G3").Copy
Worksheets("Sheet1").Range("B3").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("F3").Copy
Worksheets("Sheet1").Range("B19").PasteSpecial Paste:=xlPasteFormulas
ActiveSheet.PrintOut

Loop


'Report out first blank cell found in Column A
MsgBox " All backhauls printed!"


End Sub

I would be appreciate for help.
Regards

anna

 

[MARK858]

Are you saying you want it to run until the last row of data in column A or is there data after the first blank cell in column A?

 

[Anna314]

Are you saying you want it to run until the last row of data in column A or is there data after the first blank cell in column A?

I want to run until the last row of data in column A. There will be no blank cells between rows

 

[MARK858]

Does the code below give the correct results?

Private Sub CommandButton1_Click()

Dim x As Long

For x = 2 To Cells(Rows.Count, "A").End(xlUp).Row

Worksheets("Sheet2").Range("A" & x).Copy
Worksheets("Sheet1").Range("B7").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("B" & x).Copy
Worksheets("Sheet1").Range("B11").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("C" & x).Copy
Worksheets("Sheet1").Range("D7").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("D" & x).Copy
Worksheets("Sheet1").Range("D3").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("E" & x).Copy
Worksheets("Sheet1").Range("D11").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("G" & x).Copy
Worksheets("Sheet1").Range("B3").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("F" & x).Copy
Worksheets("Sheet1").Range("B19").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet1").PrintOut

Next

'Report out first blank cell found in Column A
 MsgBox " All backhauls printed!"


End Sub

 

[Anna314]

It works. Thank you so much for your time. I'm so grateful and appreciate that you helped me. I think this is the feeling that everyone has once the issue is sorted. Thank you so much again.

Does the code below give the correct results?

Private Sub CommandButton1_Click()

Dim x As Long

For x = 2 To Cells(Rows.Count, "A").End(xlUp).Row

Worksheets("Sheet2").Range("A" & x).Copy
Worksheets("Sheet1").Range("B7").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("B" & x).Copy
Worksheets("Sheet1").Range("B11").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("C" & x).Copy
Worksheets("Sheet1").Range("D7").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("D" & x).Copy
Worksheets("Sheet1").Range("D3").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("E" & x).Copy
Worksheets("Sheet1").Range("D11").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("G" & x).Copy
Worksheets("Sheet1").Range("B3").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet2").Range("F" & x).Copy
Worksheets("Sheet1").Range("B19").PasteSpecial Paste:=xlPasteFormulas

Worksheets("Sheet1").PrintOut

Next

'Report out first blank cell found in Column A
 MsgBox " All backhauls printed!"


End Sub

 

[MARK858]

Happy it helped and welcome to the forum,