Adding current date after each copied row

[wlknspc7]

Hello!
I have a working VBA macro which copies rows based on a criteria to a new worksheet and deletes rows based on this same criteria from the older ws.
Right now my code looks like this and what I want is the current date added next to each copied row (in the "P" column)
I figured out how to add the current date in a cell but I can't implement it into my macro.

Sub Teljesített_másol_töröl()
Dim gyujto As Worksheet
Dim cel As Worksheet
Dim statusz As String
Dim utolso As Integer
Dim i As Integer
Dim x As Double

Set gyujto = Munka1
Set cel = Munka2
'statusz = gyujto.Range("R2").Value
x = 0

gyujto.Select
utolso = Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To utolso
If Cells(i, 13) = "T" Then
Range(Cells(i, 1), Cells(i, 15)).Copy
cel.Select
Range("A500").End(xlUp).Offset(1, 0).Select
Selection.Insert Shift:=xlDown
x = x + 1
End If

Next i
gyujto.Select
For i = utolso To 2 Step -1
If Cells(i, 13) = "T" Then
Rows(i & ":" & i).EntireRow.Delete
End If

Next i
cel.Select
MsgBox x & " sor másolva"

End Sub

Thanks in advance!

 

[HaHoBe]

Hi,

why not use one loop and avoid changing sheets? Try this code:

Sub Teljesített_másol_töröl_120521()
Dim wsFrom As Worksheet
Dim wsTo As Worksheet
'Dim statusz As String
Dim utolso As Integer
Dim i As Integer
Dim x As Double

Set wsFrom = Munka1
Set wsTo = Munka2
'statusz = wsFrom.Range("R2").Value
x = 0

utolso = wsFrom.Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False
For i = 2 To utolso
  If wsFrom.Cells(i, 13) = "T" Then
    With wsFrom.Range("A" & i).Resize(1, 15)
      wsTo.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 15).Value = .Value
      wsTo.Range("A" & Rows.Count).End(xlUp).Offset(, 15).Value = Date
      .ClearContents
    End With
    x = x + 1
  End If
Next i
Application.ScreenUpdating = True

wsTo.Select
MsgBox x & " sor másolva"

End Sub

Ciao,
Holger

 

[wlknspc7]

Hi,

why not use one loop and avoid changing sheets? Try this code:

Sub Teljesített_másol_töröl_120521()
Dim wsFrom As Worksheet
Dim wsTo As Worksheet
'Dim statusz As String
Dim utolso As Integer
Dim i As Integer
Dim x As Double

Set wsFrom = Munka1
Set wsTo = Munka2
'statusz = wsFrom.Range("R2").Value
x = 0

utolso = wsFrom.Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False
For i = 2 To utolso
  If wsFrom.Cells(i, 13) = "T" Then
    With wsFrom.Range("A" & i).Resize(1, 15)
      wsTo.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 15).Value = .Value
      wsTo.Range("A" & Rows.Count).End(xlUp).Offset(, 15).Value = Date
      .ClearContents
    End With
    x = x + 1
  End If
Next i
Application.ScreenUpdating = True

wsTo.Select
MsgBox x & " sor másolva"

End Sub

Ciao,
Holger

Hi thanks for the help!

I'm new to VBA this is why I don't know about the best possible solutions yet.
Your code is really great and works well but how do I modify it to paste specials and formatting as well?
The rows I'm copying usually have links in them and keeping the formatting would be nice.
And if possible I need the rows deleted entirely not only the content, this is why I used the other "For i = utolso To 2 Step -1" method in my previous code because it wasn't working properly otherwise (the deleting method ran only half as many times as it was supposed to)

 

[HaHoBe]

Hi wlknspc,

if you want to delete rows you should start at the last row and work upwards. Just think of the counter to show 3 for row 3. If you delete that row the contents of the lower rows shift up and the row 3 shows what was formerly row 4 but your counter will go on with 4 instead. Starting at the last row avoids that problem. And working on the counter of a For...Next loop manipulating both the counter as well as the total isn´t what I would do for a solid working code.

Anyhow we´ll start at the top with a different approach and build a range with the cells to be deleted and delete these (if any) at the end like

Sub Teljesített_másol_töröl_120521Mod2()
Dim wsFrom As Worksheet
Dim wsTo As Worksheet
Dim utolso As Integer
Dim i As Integer
Dim x As Double
Dim rngDelete As Range

Set wsFrom = Munka1   'you may use the codename instead of setting an object to a worksheet
Set wsTo = Munka2
x = 0

utolso = wsFrom.Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False


For i = 2 To utolso
  If wsFrom.Cells(i, 13) = "T" Then
    With wsFrom.Range("A" & i).Resize(1, 15)
      .Copy wsTo.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)       'this sgould take care of formatting etc.
      wsTo.Range("A" & Rows.Count).End(xlUp).Offset(, 15).Value = Date
      'build the range to delete
      If rngDelete Is Nothing Then
        Set rngDelete = wsFrom.Range("A" & i)
      Else
        Set rngDelete = Union(rngDelete, wsFrom.Range("A" & i))
      End If
    End With
    x = x + 1
  End If
Next i
Application.ScreenUpdating = True

If Not rngDelete Is Nothing Then
  rngDelete.EntireRow.Delete
  Set rngDelete = Nothing
End If

wsTo.Select
MsgBox x & " sor másolva"

Set wsTo = Nothing
Set wsFrom = Nothing
End Sub

Ciao,
Hiolger

 

[wlknspc7]

Hi wlknspc,

if you want to delete rows you should start at the last row and work upwards. Just think of the counter to show 3 for row 3. If you delete that row the contents of the lower rows shift up and the row 3 shows what was formerly row 4 but your counter will go on with 4 instead. Starting at the last row avoids that problem. And working on the counter of a For...Next loop manipulating both the counter as well as the total isn´t what I would do for a solid working code.

Anyhow we´ll start at the top with a different approach and build a range with the cells to be deleted and delete these (if any) at the end like

Sub Teljesített_másol_töröl_120521Mod2()
Dim wsFrom As Worksheet
Dim wsTo As Worksheet
Dim utolso As Integer
Dim i As Integer
Dim x As Double
Dim rngDelete As Range

Set wsFrom = Munka1   'you may use the codename instead of setting an object to a worksheet
Set wsTo = Munka2
x = 0

utolso = wsFrom.Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False


For i = 2 To utolso
  If wsFrom.Cells(i, 13) = "T" Then
    With wsFrom.Range("A" & i).Resize(1, 15)
      .Copy wsTo.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)       'this sgould take care of formatting etc.
      wsTo.Range("A" & Rows.Count).End(xlUp).Offset(, 15).Value = Date
      'build the range to delete
      If rngDelete Is Nothing Then
        Set rngDelete = wsFrom.Range("A" & i)
      Else
        Set rngDelete = Union(rngDelete, wsFrom.Range("A" & i))
      End If
    End With
    x = x + 1
  End If
Next i
Application.ScreenUpdating = True

If Not rngDelete Is Nothing Then
  rngDelete.EntireRow.Delete
  Set rngDelete = Nothing
End If

wsTo.Select
MsgBox x & " sor másolva"

Set wsTo = Nothing
Set wsFrom = Nothing
End Sub

Ciao,
Hiolger

Thank you!

It's working great, i'm not sure if I could have ever figured this out on my own but I learned a lot.

 

[HaHoBe]

Hi wlknspc,

if you are happy with the solution provided please mark the thread Solved.

Ciao,
Holger