| Home |
| Search |
| Today's Posts |
|
|
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
|
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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 |
|
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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 |
|
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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 |
|
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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 |
| Reply |
| Thread Tools | Search this Thread |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Forum | |||
| Insert multiple rows | Excel Discussion (Misc queries) | |||
| how do insert multiple rows in between multiple lines | Excel Discussion (Misc queries) | |||
| Insert Multiple Rows | Excel Discussion (Misc queries) | |||
| how do I insert multiple rows in excel after every row of data | Excel Discussion (Misc queries) | |||
| Insert multiple rows | Excel Programming | |||
Hybrid Mode
