Copy information worksheet to worksheet

[Casey]

Hi VBA Gurus,
I need some help with a routine to copy specific information from one worksheet to another worksheet in the same workbook.
In the first worksheet, column G contains either a zero or an integer between 1 and twenty five.
I need a routine to go down column G starting at G5 and check the value of the G cell (the first one is G5) if it is zero go to the next cell down in G column. If the G has an integer in it, then copy the corresponding (same row) contents of column A, B and F to the second worksheet in columns A,B& C. Here is the tough part for me. I need it to make as many copies as the value of the integer in column G.
For example:
If the first two rows had a Zero value in column G nothing would get pasted into the second worksheet, but is the third row had a “3” then 3 instances of column A,B, and F from the first worksheet would be copied to the second worksheet to columns A,B and C.
I’m wanting to use a control command button to start the process.
Thanks in advance for any help.

Here is my code

Sub Import_Headers_To_Header_Sheet()

Dim i As Integer
Dim j As Integer
Dim intRowCount As Integer

Application.ScreenUpdating = False
Worksheets("WALL TAKE-OFF").Range("G5").Select
j = ActiveCell.Value
intRowCount = Range("A5").CurrentRegion.Rows.Count - 1
For i = 1 To intRowCount
For Each i In intRowCount
If i>0
Then ActiveCell.Offset(0, -6, 0, -5, 0, -1).Copy
Worksheets("WALL HEADER TAKEOFF").Range("G3").Select
Call ActivateNextBlankDown
'use FillDown method and Offset method to paste items using j value to trigger how ‘many times???
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next i
ActiveCell.Offset(1, 0).Select
Next i
Application.ScreenUpdating = True
End Sub

Private Sub Import_Header_Quan_Location_Click()
Call Import_Headers_To_Header_Sheet
End Sub

Sub ActivateNextBlankDown()
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
End Sub

[Leith Ross]

Hi VBA Gurus,
I need some help with a routine to copy specific information from one worksheet to another worksheet in the same workbook.
In the first worksheet, column G contains either a zero or an integer between 1 and twenty five.
I need a routine to go down column G starting at G5 and check the value of the G cell (the first one is G5) if it is zero go to the next cell down in G column. If the G has an integer in it, then copy the corresponding (same row) contents of column A, B and F to the second worksheet in columns A,B& C. Here is the tough part for me. I need it to make as many copies as the value of the integer in column G.
For example:
If the first two rows had a Zero value in column G nothing would get pasted into the second worksheet, but is the third row had a “3” then 3 instances of column A,B, and F from the first worksheet would be copied to the second worksheet to columns A,B and C.
I’m wanting to use a control command button to start the process.
Thanks in advance for any help.



Here is my code

Sub Import_Headers_To_Header_Sheet()

Dim i As Integer
Dim j As Integer
Dim intRowCount As Integer

Application.ScreenUpdating = False
Worksheets("WALL TAKE-OFF").Range("G5").Select
j = ActiveCell.Value
intRowCount = Range("A5").CurrentRegion.Rows.Count - 1
For i = 1 To intRowCount
For Each i In intRowCount
If i>0
Then ActiveCell.Offset(0, -6, 0, -5, 0, -1).Copy
Worksheets("WALL HEADER TAKEOFF").Range("G3").Select
Call ActivateNextBlankDown
'use FillDown method and Offset method to paste items using j value to trigger how ‘many times???
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next i
ActiveCell.Offset(1, 0).Select
Next i
Application.ScreenUpdating = True
End Sub

Private Sub Import_Header_Quan_Location_Click()
Call Import_Headers_To_Header_Sheet
End Sub

Sub ActivateNextBlankDown()
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
End Sub

Hello Casey,

Try this code out . Paste it into your Command Buttons Click Routine.
________________________________________________________________

Private Sub CommandButton1_Click()

'Copy Command Button

Dim Wks1 As Worksheet
Dim Wks2 As Worksheet
Dim CopyRow As Long
Dim Entries As Long
Dim I As Long
Dim J As Long

'Change the Sheet Names to Your Names
Set Wks1 = Worksheets("Sheet1")
Set Wks2 = Worksheets("Sheet2")

CopyRow = 1
Entries = Excel.WorksheetFunction.CountA(Wks1.Range("G:G"))

For I = 5 To Entries + 4
N = Wks1.Cells(I, 7).Value
If N <> 0 Then
For J = 1 To N
With Wks2
.Cells(CopyRow, 1).Value = Wks1.Cells(I, 1).Value
.Cells(CopyRow, 2).Value = Wks1.Cells(I, 2).Value
.Cells(CopyRow, 3).Value = Wks1.Cells(I, 6).Value
End With
CopyRow = CopyRow + 1
Next J
End If
Next I

End Sub
________________________________________________________________

Should do the job, if not contact by e-mail or IM if I'm not in the Forum

Leith Ross

[Casey]

Leith,
Thank you very much for the help. There is a problem though.
The procedure stops short. It only copied and pasted data (exactly as desired) down to row 29 and quit. There are at this time 86 rows of data.
I'm not sure if it has anything to do with the quiting but under row 29 there are 4 empty cells in column G until the next bit of data.

Below is your code as modified .

Private Sub Import_Header_Quan_Location_Click()

Dim Wks1 As Worksheet
Dim Wks2 As Worksheet
Dim CopyRow As Long
Dim Entries As Long
Dim I As Long
Dim J As Long


Set Wks1 = Worksheets("WALL TAKE-OFF")
Set Wks2 = Worksheets("WALL HEADER TAKEOFF")
'changed CopyRow to 3 to prevent overriding permanemt column headings
CopyRow = 3
Entries = Excel.WorksheetFunction.CountA(Wks1.Range("G:G"))

For I = 5 To Entries + 4
N = Wks1.Cells(I, 7).Value
If N <> 0 Then
For J = 1 To N
With Wks2
.Cells(CopyRow, 1).Value = Wks1.Cells(I, 1).Value
.Cells(CopyRow, 2).Value = Wks1.Cells(I, 2).Value
.Cells(CopyRow, 3).Value = Wks1.Cells(I, 6).Value
End With
CopyRow = CopyRow + 1
Next J
End If
Next I

End Sub

[Casey]

Leith,
I made a modification to the code which seems to have cured the problem. But I don't know exactly why it worked. I changed the line of code:

For I = 5 To Entries + 4 .....to:

For I = 5 To Entries + 100

Any enlightenment would be greatly appreciated.

Many thanks for the help.

[Leith Ross]

Hi Casey,
Thanks for the feedback. The empty cells may be a problem. The Code tests the cell value to see if it zero. However, an empty cell is not always equal to zero. The cell may either be an empty string or Null. An empty string will convert to zero, but a Nullwill not.

Change the Cell test to this:

For I = 5 To Entries + 4
N = Wks1.Cells(I, 7).Value
If Not IsNull(N) And N <> 0 Then
For J = 1 To N
With Wks2
.Cells(CopyRow, 1).Value = Wks1.Cells(I, 1).Value
.Cells(CopyRow, 2).Value = Wks1.Cells(I, 2).Value
.Cells(CopyRow, 3).Value = Wks1.Cells(I, 6).Value
End With
CopyRow = CopyRow + 1
Next J
End If
Next I


That should cure the problem, if not we'll keep trying.

Thanks,
Leith

[Casey]

Leith,
Tried the code change. Execution reverted back to quitting after the twenty ninth row. Checked format and it is definately set as a number with zero decimal places. However, changing the line of code:

For I = 5 To Entries + 4 .....to:

For I = 5 To Entries + 100

Still seems to cure the problem though I don't know why. Here again is my modified code:


'Code by Leigh Ross via Excel Forum 1/17/05

Private Sub Import_Header_Quan_Location_Click()

Dim Wks1 As Worksheet
Dim Wks2 As Worksheet
Dim CopyRow As Long
Dim Entries As Long
Dim I As Long
Dim J As Long

Msg = MsgBox("Wall Take-off is complete and you are ready to import the Header quantities ?", vbYesNo + vbQuestion, "Import Headers from WALL TAKE-OFF")
If Msg = 6 Then
Application.ScreenUpdating = False

Set Wks1 = Worksheets("WALL TAKE-OFF")
Set Wks2 = Worksheets("WALL HEADER TAKEOFF")
'changed CopyRow to 3 to prevent overriding permanemt column headings


CopyRow = 3
Entries = Excel.WorksheetFunction.CountA(Wks1.Range("G:G"))

For I = 5 To Entries + 100
N = Wks1.Cells(I, 7).Value
If Not IsNull(N) And N <> 0 Then
For J = 1 To N
With Wks2
.Cells(CopyRow, 1).Value = Wks1.Cells(I, 1).Value
.Cells(CopyRow, 2).Value = Wks1.Cells(I, 2).Value
.Cells(CopyRow, 3).Value = Wks1.Cells(I, 6).Value
End With
CopyRow = CopyRow + 1
Next J
End If
Next I
Application.ScreenUpdating = True
End If
If Msg = 7 Then
Exit Sub

End If
End Sub

[Leith Ross]

Hi Casey,

How about putting a break point in the code at the start of the loop and check Entries to see what the value is. Let me know what you find. This is very strange.

Thanks Again,
Leith

[Casey]

Hi Leith,
I put a Watch on the line

For I = 5 To Entries + 100

The value comes up 30

Should come up 85 for the current data.

Leith,
This G column doesn't contain a formula. The numbers are entered directly. The Data validation is set to whole numbers between 0 & 100 would that cause a problem?