PDA

View Full Version : [SOLVED] Insert row and paste data into (modify code)



izet99
09-26-2014, 11:55 AM
Hi, have a little marco code below that work great but I would like to modify destination...

For example, how do I set destination to specific cell, let say cell start from C25, insert new row and paste data in it. Basicly, I have data in C24 and C30, I need code below to insert copied data between C24:C30 range. Data that will be inserted varies in size/number of row so I would need push down existing used row in C30. Anybody have any idea to to modify existing code?

Destination code, where I have issue with:

.Range("B" & i).EntireRow.Copy _
Destination:=ws.Range("C65536").End(xlUp).Offset(1, 0)


Full code below... it distribution data from one sheet to multiple sheet if value in column match.

Sub DistributeData()


Dim i As Long
Dim LastRow As Long
Dim ws As Worksheet
Dim ErrorLog As String


With Sheets("all")
LastRow = .Range("C65536").End(xlUp).Row
For i = 40 To LastRow
On Error Resume Next
Set ws = Sheets(.Range("B" & i).Text)
On Error GoTo 0
If ws Is Nothing Then
ErrorLog = ErrorLog & vbNewLine & _
"Row:" & i & " Sheet Name: " & .Range("C" & i).Text
Else
.Range("B" & i).EntireRow.Copy _
Destination:=ws.Range("C65536").End(xlUp).Offset(1, 0)
End If
Set ws = Nothing
Next i
End With

Set ws = Nothing

End Sub


Regards,
Izet

izet99
09-27-2014, 11:35 AM
Attaching sample file with working code.... need to modify destination code to paste data into specific cell and push rest of rows down. Any help and support would be greatly appreciated.

12317

p45cal
09-27-2014, 03:45 PM
your macro tweaked:
Sub DistributeData()
'http://www.vbaexpress.com/forum/showthread.php?50840-Insert-row-and-paste-data-into-%28modify-code%29
Dim i As Long
Dim LastRow As Long
Dim ws As Worksheet
Dim ErrorLog As String

' Data sheet / SB's list
With Sheets("Master")
' Set range of selected modules
LastRow = .Range("A65536").End(xlUp).Row
For i = LastRow To 10 Step -1
On Error Resume Next
' Count selected mudules
Set ws = Sheets(.Range("B" & i).Text)
On Error GoTo 0
If ws Is Nothing Then
ErrorLog = ErrorLog & vbNewLine & "Row:" & i & " Sheet Name: " & .Range("C" & i).Text
Else
'.Range("B" & i).EntireRow.Copy _'
' Column to be copied and set destination where it will be pasted
ws.Rows(14).Insert
.Range("D" & i).Copy Destination:=ws.Range("C14")
End If
Set ws = Nothing
Next i
End With

'If ErrorLog <> "" Then
'ErrorLog = "The following worksheets could not be found " & '"and the data was not transfered over." & vbNewLine & vbNewLine & ErrorLog
'MsgBox ErrorLog
'End If

Set ws = Nothing

End Sub

westconn1
09-27-2014, 03:49 PM
you can try like, to see if it does as required, you may need to change the colour of the cells as it appears to copy the header colours down, when inserting

ws.Range("c14").EntireRow.Insert (xlShiftDown)
.Range("D" & i).Copy Destination:=ws.Range("C14")

izet99
09-27-2014, 06:56 PM
Hi p45cal,

Modification works perfect, just as I wanted....

Westconn1,
Changing target cell from C14 to C15 solved issue of copying heading color issue.

Just want to thank you and appreciate your help. Also, if you're up for additional challenge, I have posted few other items I'm working on, just in case if you may have some feedback or suggestion.

Once again, thank you very much for help on modifying code.

Update: Just adding final copy of file with updated script, maybe somebody else can use it as well.
12318

Regards,
Izet