Insert Multiple rows with data

  • Thread starter Thread starter whitethomas12
  • Start date Start date
W

whitethomas12

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
 
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
Click to expand...

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
 
<[email protected]> skrev i en meddelelse

















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 -
Click to expand...

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
 
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 -
Click to expand...

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
 
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 -
Click to expand...

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
 
Back
Top