Insert Multiple rows with data
 

I have a quick question.

I have been trying to copy data from one worksheet and inserting it
into another. if I just want to paste it into the other then it will
work, but if I have the code insert rows first then it fails.

The following is my code:

Dim x As String
Range("A2").Select
Do While ActiveCell.Value < ""
Dim nDataRange As Range
Dim InsQuan As Long

x = ActiveCell.Value
Sheets("Sheet1").Select
Set nDataRange = Nothing
Range("J1").Select
Do While ActiveCell.Value < ""
If ActiveCell.Value = x Then
InsQuan = InsQuan + 1
If nDataRange Is Nothing Then
Set nDataRange = ActiveCell
Else
Set nDataRange = Union(nDataRange, ActiveCell)
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
'nDataRange.EntireRow.Select
nDataRange.EntireRow.Copy
Sheets("Sheet4").Select

ActiveCell.Offset(1, 0).Select
ActiveCell.Insert shift:=xlDown
ActiveSheet.Paste
' ActiveCell.Offset(1, 0).Range("A1:A" & InsQuan).Select
'Selection.Insert Shift:=xlDown
''ActiveCell.Select


''ActiveCell.Offset(1, 0).Insert shift:=xlDown
''ActiveCell.Insert shift:=xlDown
''ActiveCell.Offset(1, 0).Select
''Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
'' False, Transpose:=False
''Selection.Insert shift:=xlDown

'ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Loop

'ActiveCell.Offset(1, 0).Select

So basically what my code is doing is selecting a name from the target
worksheet and then looping through the worksheet with the data, then
it is trying to insert rows just under the search criteria in the
target page. From here I would like it to insert the data without
deleting all of the other data.

As you can tell by my commit outs of vb code. I have tried several
options

Will someone please assist me

Thank you for all of your help

Insert Multiple rows with data
 

skrev i en meddelelse
...
I have a quick question.

I have been trying to copy data from one worksheet and inserting it
into another. if I just want to paste it into the other then it will
work, but if I have the code insert rows first then it fails.

The following is my code:

Dim x As String
Range("A2").Select
Do While ActiveCell.Value < ""
Dim nDataRange As Range
Dim InsQuan As Long

x = ActiveCell.Value
Sheets("Sheet1").Select
Set nDataRange = Nothing
Range("J1").Select
Do While ActiveCell.Value < ""
If ActiveCell.Value = x Then
InsQuan = InsQuan + 1
If nDataRange Is Nothing Then
Set nDataRange = ActiveCell
Else
Set nDataRange = Union(nDataRange, ActiveCell)
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
'nDataRange.EntireRow.Select
nDataRange.EntireRow.Copy
Sheets("Sheet4").Select

ActiveCell.Offset(1, 0).Select
ActiveCell.Insert shift:=xlDown
ActiveSheet.Paste
' ActiveCell.Offset(1, 0).Range("A1:A" & InsQuan).Select
'Selection.Insert Shift:=xlDown
''ActiveCell.Select


''ActiveCell.Offset(1, 0).Insert shift:=xlDown
''ActiveCell.Insert shift:=xlDown
''ActiveCell.Offset(1, 0).Select
''Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
'' False, Transpose:=False
''Selection.Insert shift:=xlDown

'ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Loop

'ActiveCell.Offset(1, 0).Select

So basically what my code is doing is selecting a name from the target
worksheet and then looping through the worksheet with the data, then
it is trying to insert rows just under the search criteria in the
target page. From here I would like it to insert the data without
deleting all of the other data.

As you can tell by my commit outs of vb code. I have tried several
options

Will someone please assist me

Thank you for all of your help

Hi

Try this out!

Sub CopyRows()
Application.ScreenUpdating = False
Dim Name As String
Dim i As Single
Sheets("Sheet4").Select
Range("A2").Select
Name = ActiveCell.Value
Do While Name < ""
Sheets("Sheet1").Select
Range("J1").Select
Do While ActiveCell.Value < ""
If ActiveCell.Value = Name Then
ActiveCell.EntireRow.Copy
Sheets("Sheet4").Select
ActiveCell.Offset(1, 0).Select
ActiveCell.EntireRow.Insert shift:=xlDown
ActiveSheet.Paste
End If
Sheets("Sheet1").Select
ActiveCell.Offset(1, 0).Select
Loop
Sheets("Sheet4").Select
ActiveCell.Offset(1, 0).Select
Name = ActiveCell.Value
Loop
Application.ScreenUpdating = True
End Sub

Insert Multiple rows with data
 

On Jan 5, 8:04*am, "Per Jessen" wrote:
skrev i en ...





I have a quick question.

I have been trying to copy data from one worksheet and inserting it
into another. *if I just want to paste it into the other then it will
work, but if I have the code insert rows first then it fails.

The following is my code:

Dim x As String
Range("A2").Select
Do While ActiveCell.Value < ""
Dim nDataRange As Range
Dim InsQuan As Long

*x = ActiveCell.Value
*Sheets("Sheet1").Select
*Set nDataRange = Nothing
*Range("J1").Select
*Do While ActiveCell.Value < ""
* If ActiveCell.Value = x Then
* * InsQuan = InsQuan + 1
* * If nDataRange Is Nothing Then
* * * Set nDataRange = ActiveCell
* * Else
* * * Set nDataRange = Union(nDataRange, ActiveCell)
* * End If
* End If
* ActiveCell.Offset(1, 0).Select
* Loop
* 'nDataRange.EntireRow.Select
* nDataRange.EntireRow.Copy
* Sheets("Sheet4").Select

* ActiveCell.Offset(1, 0).Select
* ActiveCell.Insert shift:=xlDown
* ActiveSheet.Paste
' *ActiveCell.Offset(1, 0).Range("A1:A" & InsQuan).Select
'Selection.Insert Shift:=xlDown
''ActiveCell.Select

* ''ActiveCell.Offset(1, 0).Insert shift:=xlDown
* ''ActiveCell.Insert shift:=xlDown
* ''ActiveCell.Offset(1, 0).Select
* ''Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
* *'' * *False, Transpose:=False
* ''Selection.Insert shift:=xlDown

* 'ActiveSheet.Paste
* ActiveCell.Offset(1, 0).Select
Loop

'ActiveCell.Offset(1, 0).Select

So basically what my code is doing is selecting a name from the target
worksheet and then looping through the worksheet with the data, then
it is trying to insert rows just under the search criteria in the
target page. *From here I would like it to insert the data without
deleting all of the other data.

As you can tell by my commit outs of vb code. *I have tried several
options

Will someone please assist me

Thank you for all of your help

Hi

Try this out!

Sub CopyRows()
Application.ScreenUpdating = False
Dim Name As String
Dim i As Single
Sheets("Sheet4").Select
Range("A2").Select
Name = ActiveCell.Value
Do While Name < ""
* * Sheets("Sheet1").Select
* * Range("J1").Select
* * * * Do While ActiveCell.Value < ""
* * * * * * If ActiveCell.Value = Name Then
* * * * * * * * ActiveCell.EntireRow.Copy
* * * * * * * * Sheets("Sheet4").Select
* * * * * * * * ActiveCell.Offset(1, 0).Select
* * * * * * * * ActiveCell.EntireRow.Insert shift:=xlDown
* * * * * * * * ActiveSheet.Paste
* * * * * * End If
* * * * Sheets("Sheet1").Select
* * * * ActiveCell.Offset(1, 0).Select
* * * * Loop
* * Sheets("Sheet4").Select
* * ActiveCell.Offset(1, 0).Select
* * Name = ActiveCell.Value
Loop
Application.ScreenUpdating = True
End Sub- Hide quoted text -

- Show quoted text -

I tried something different and it seems to work the first time. The
scenior that I have is that I have one worksheet (sheet4) that has a
list of names and another worksheet (sheet1) with times that the
person has clocked in. What I need that macro to do is go through
sheet4 and get a name and then go to sheet1 and copy all the times
that the person has clocked in and then loop through the process.

The following is what I have now:

Dim x As String
Dim nDataRange As Range
Dim InsQuan As Long
Range("A2").Select
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Do While ActiveCell.Value < ""
InsQuan = 0
x = ActiveCell.Value

Sheets("Sheet1").Select
Range("J1").Select
Do While ActiveCell.Value < ""
If ActiveCell.Value = x Then
InsQuan = InsQuan + 1
End If
ActiveCell.Offset(1, 0).Select
Loop
Sheets("Sheet4").Select

ActiveCell.EntireRow.Offset(1, 0).Range("A1:A" & InsQuan).Select
Selection.Insert Shift:=xlDown
Sheets("Sheet1").Select
Set nDataRange = Nothing
Range("J1").Select
Do While ActiveCell.Value < ""
If ActiveCell.Value = x Then
If nDataRange Is Nothing Then
Set nDataRange = ActiveCell
Else
Set nDataRange = Union(nDataRange, ActiveCell)
End If
End If

ActiveCell.Offset(1, 0).Select

Loop
If nDataRange Is Nothing Then
MsgBox "No cells found! "
Else
nDataRange.EntireRow.Copy

Sheets("Sheet4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
ActiveCell.Offset(1, 0).Select
End If
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

I think I can create another loop to find the next name, but as you
can see I am getting into many loops. I would like to make this macro
to run as fast as possible

Once again thank you for all of your help

Insert Multiple rows with data
 

On Jan 7, 11:06*am, wrote:
On Jan 5, 8:04*am, "Per Jessen" wrote:





skrev i en ...

I have a quick question.

I have been trying to copy data from one worksheet and inserting it
into another. *if I just want to paste it into the other then it will
work, but if I have the code insert rows first then it fails.

The following is my code:

Dim x As String
Range("A2").Select
Do While ActiveCell.Value < ""
Dim nDataRange As Range
Dim InsQuan As Long

*x = ActiveCell.Value
*Sheets("Sheet1").Select
*Set nDataRange = Nothing
*Range("J1").Select
*Do While ActiveCell.Value < ""
* If ActiveCell.Value = x Then
* * InsQuan = InsQuan + 1
* * If nDataRange Is Nothing Then
* * * Set nDataRange = ActiveCell
* * Else
* * * Set nDataRange = Union(nDataRange, ActiveCell)
* * End If
* End If
* ActiveCell.Offset(1, 0).Select
* Loop
* 'nDataRange.EntireRow.Select
* nDataRange.EntireRow.Copy
* Sheets("Sheet4").Select

* ActiveCell.Offset(1, 0).Select
* ActiveCell.Insert shift:=xlDown
* ActiveSheet.Paste
' *ActiveCell.Offset(1, 0).Range("A1:A" & InsQuan).Select
'Selection.Insert Shift:=xlDown
''ActiveCell.Select

* ''ActiveCell.Offset(1, 0).Insert shift:=xlDown
* ''ActiveCell.Insert shift:=xlDown
* ''ActiveCell.Offset(1, 0).Select
* ''Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
* *'' * *False, Transpose:=False
* ''Selection.Insert shift:=xlDown

* 'ActiveSheet.Paste
* ActiveCell.Offset(1, 0).Select
Loop

'ActiveCell.Offset(1, 0).Select

So basically what my code is doing is selecting a name from the target
worksheet and then looping through the worksheet with the data, then
it is trying to insert rows just under the search criteria in the
target page. *From here I would like it to insert the data without
deleting all of the other data.

As you can tell by my commit outs of vb code. *I have tried several
options

Will someone please assist me

Thank you for all of your help

Hi

Try this out!

Sub CopyRows()
Application.ScreenUpdating = False
Dim Name As String
Dim i As Single
Sheets("Sheet4").Select
Range("A2").Select
Name = ActiveCell.Value
Do While Name < ""
* * Sheets("Sheet1").Select
* * Range("J1").Select
* * * * Do While ActiveCell.Value < ""
* * * * * * If ActiveCell.Value = Name Then
* * * * * * * * ActiveCell.EntireRow.Copy
* * * * * * * * Sheets("Sheet4").Select
* * * * * * * * ActiveCell.Offset(1, 0).Select
* * * * * * * * ActiveCell.EntireRow.Insert shift:=xlDown
* * * * * * * * ActiveSheet.Paste
* * * * * * End If
* * * * Sheets("Sheet1").Select
* * * * ActiveCell.Offset(1, 0).Select
* * * * Loop
* * Sheets("Sheet4").Select
* * ActiveCell.Offset(1, 0).Select
* * Name = ActiveCell.Value
Loop
Application.ScreenUpdating = True
End Sub- Hide quoted text -

- Show quoted text -

I tried something different and it seems to work the first time. *The
scenior that I have is that I have one worksheet (sheet4) that has a
list of names and another worksheet (sheet1) with times that the
person has clocked in. *What I need that macro to do is go through
sheet4 and get a name and then go to sheet1 and copy all the times
that the person has clocked in and then loop through the process.

The following is what I have now:

Dim x As String
Dim nDataRange As Range
Dim InsQuan As Long
Range("A2").Select
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Do While ActiveCell.Value < ""
* InsQuan = 0
* x = ActiveCell.Value

* Sheets("Sheet1").Select
* Range("J1").Select
* Do While ActiveCell.Value < ""
* If ActiveCell.Value = x Then
* * *InsQuan = InsQuan + 1
* * *End If
* * *ActiveCell.Offset(1, 0).Select
* Loop
* Sheets("Sheet4").Select

* ActiveCell.EntireRow.Offset(1, 0).Range("A1:A" & InsQuan).Select
* * * Selection.Insert Shift:=xlDown
* Sheets("Sheet1").Select
* Set nDataRange = Nothing
* Range("J1").Select
* Do While ActiveCell.Value < ""
* *If ActiveCell.Value = x Then
* * *If nDataRange Is Nothing Then
* * * *Set nDataRange = ActiveCell
* * *Else
* * * *Set nDataRange = Union(nDataRange, ActiveCell)
* * *End If
* *End If

* *ActiveCell.Offset(1, 0).Select

* *Loop
* *If nDataRange Is Nothing Then
* *MsgBox "No cells found! "
* *Else
* *nDataRange.EntireRow.Copy

* *Sheets("Sheet4").Select
* *Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
* * * * False, Transpose:=False
* * ActiveCell.Offset(1, 0).Select
* *End If
* *ActiveCell.Offset(1, 0).Select
*Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

I think I can create another loop to find the next name, but as you
can see I am getting into many loops. I would like to make this macro
to run as fast as possible

Once again thank you for all of your help- Hide quoted text -

- Show quoted text -

OK, I got it to work by creating another loop, but I am not sure if
this is the most perficient way to it. If anyone knows how to
recreate the code to be more perficient please let me know. The
following is my new code:

Sub Copy_RowsByCriteria()
Dim x As String
Dim nDataRange As Range
Dim InsQuan As Long
Range("A2").Select
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Do While ActiveCell.Value < ""
InsQuan = 0
If x < "" Then
Do While ActiveCell.Offset(0, 9).Value = x
ActiveCell.Offset(1, 0).Select
Loop
If Not ActiveCell.Value < "" Then
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Range("A1").Select
MsgBox "Finished! "
Exit Sub
Else
x = ActiveCell.Value
End If
Else
x = ActiveCell.Value
End If
Sheets("Sheet1").Select
Range("J1").Select
Do While ActiveCell.Value < ""
If ActiveCell.Value = x Then
InsQuan = InsQuan + 1
End If
ActiveCell.Offset(1, 0).Select
Loop
Sheets("Sheet4").Select
ActiveCell.EntireRow.Offset(1, 0).Range("A1:A" & InsQuan).Select
Selection.Insert Shift:=xlDown
Sheets("Sheet1").Select
Set nDataRange = Nothing
Range("J1").Select
Do While ActiveCell.Value < ""
If ActiveCell.Value = x Then
If nDataRange Is Nothing Then
Set nDataRange = ActiveCell
Else
Set nDataRange = Union(nDataRange, ActiveCell)
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
If nDataRange Is Nothing Then
MsgBox "No cells found! "
Else
nDataRange.EntireRow.Copy

Sheets("Sheet4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
'ActiveCell.Offset(1, 0).Select
End If
ActiveCell.Offset(1, 0).Select
Loop



End Sub

Insert Multiple rows with data
 

OK, I got it to work by creating another loop, but I am not sure if
this is the most perficient way to it. *If anyone knows how to
recreate the code to be more perficient please let me know. *The
following is my new code:

Sub Copy_RowsByCriteria()
Dim x As String
Dim nDataRange As Range
Dim InsQuan As Long
Range("A2").Select
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Do While ActiveCell.Value < ""
* InsQuan = 0
* If x < "" Then
* * Do While ActiveCell.Offset(0, 9).Value = x
* * * ActiveCell.Offset(1, 0).Select
* * Loop
* * *If Not ActiveCell.Value < "" Then
* * * Application.ScreenUpdating = True
* * * Application.Calculation = xlCalculationAutomatic
* * * Range("A1").Select
* * * MsgBox "Finished! "
* * * Exit Sub
* * *Else
* * * x = ActiveCell.Value
* * *End If
* Else
* * x = ActiveCell.Value
* End If
* Sheets("Sheet1").Select
* Range("J1").Select
* Do While ActiveCell.Value < ""
* * If ActiveCell.Value = x Then
* * * InsQuan = InsQuan + 1
* * End If
* * *ActiveCell.Offset(1, 0).Select
* Loop
* Sheets("Sheet4").Select
* ActiveCell.EntireRow.Offset(1, 0).Range("A1:A" & InsQuan).Select
* * * Selection.Insert Shift:=xlDown
* Sheets("Sheet1").Select
* Set nDataRange = Nothing
* Range("J1").Select
* Do While ActiveCell.Value < ""
* *If ActiveCell.Value = x Then
* * *If nDataRange Is Nothing Then
* * * *Set nDataRange = ActiveCell
* * *Else
* * * *Set nDataRange = Union(nDataRange, ActiveCell)
* * *End If
* *End If
* *ActiveCell.Offset(1, 0).Select
* *Loop
* *If nDataRange Is Nothing Then
* * *MsgBox "No cells found! "
* *Else
* * *nDataRange.EntireRow.Copy

* * *Sheets("Sheet4").Select
* * *Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
* * * * * False, Transpose:=False
* * 'ActiveCell.Offset(1, 0).Select
* *End If
* *ActiveCell.Offset(1, 0).Select
*Loop

End Sub- Skjul tekst i anførselstegn -

- Vis tekst i anførselstegn -

Hi again

Try this code. It should run faster as it is referring to cells rather
than selecting. I have also moved around parts of your code and
deleted som if-then sentences...

I think it will meet your needs ;-)

Sub Copy_RowsByCriteria()
Dim x As String
Dim nDataRange As Range
Dim InsQuan As Long
Dim tCell As Range
Dim dCell As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Sheet4").Select
Set tCell = Range("A2")
x = tCell.Value
Do While tCell.Value < ""
InsQuan = 0
Do While tCell.Offset(1, 9).Value = x
Set tCell = tCell.Offset(1, 0)
Loop
Sheets("Sheet1").Select
Set dCell = Range("J1")
Do While dCell.Value < ""
If dCell.Value = x Then InsQuan = InsQuan + 1
Set dCell = dCell.Offset(1, 0)
Loop
Set dCell = Range("J1")
Do While dCell.Value < ""
If dCell.Value = x Then
If nDataRange Is Nothing Then
Set nDataRange = dCell
Else
Set nDataRange = Union(nDataRange, dCell)
End If
End If
Set dCell = dCell.Offset(1, 0)
Loop
If nDataRange Is Nothing Then
MsgBox ("No cells found! ")
Else
Sheets("Sheet4").Select
tCell.Offset(1, 0).Range("A1:A" & InsQuan +
xOff).EntireRow.Insert Shift:=xlDown
nDataRange.EntireRow.Copy
tCell.Offset(1, 0).PasteSpecial Paste:=xlPasteAll,
Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
Set tCell = tCell.Offset(InsQuan + xOff + 1, 0)
x = tCell.Value
Set nDataRange = Nothing
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Range("A1").Select
MsgBox ("Finished! ")
End Sub

Regards,

Per