How to auto copy

Closed
Report
-
Posts
2829
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 22, 2021
-
Hello,
My workbook contains about 1000 sales entries on sheet 1 .
Some customers paid in full, but some other don`t.
I will put a * beside the customer`s name and copy and paste that row
to sheet 2 (and name this sheet Follow up) to distinguish that they have
not paid.

My question is how to auto copy and paste to Follow up sheet
whenever i type a *
and also on the next available row on the Follow up sheet

Thank you


4 replies

Posts
2829
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 22, 2021
490
Hello im stupid,

You didn't mention which column you use to input the *. I assumed column B, change the two B's in the second row of the code to match your column letter.

Here is the code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("B:B")) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = vbNullString Then Exit Sub

If Target.Value = "*" Then Target.EntireRow.Copy Sheets("Follow up").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Target.Select
End Sub


Best regards,
Trowa
Posts
1326
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
November 28, 2021
241
Hello Trowa,

Sorry to hijack this thread, but I have a similar query to ims above and this could actually spoil ims for choice!

I helped a friend "leelabird" with the following code (I've changed the criteria here to "*" to fall into line with the query from ims):-

Sub Copy()
Dim ws As Worksheet
Dim dSht As Worksheet
Dim dRow As Long
Dim lRow As Long
Set dSht = Worksheets("Sheet2")
Application.ScreenUpdating = False
dRow = dSht.Range("A" & Rows.Count).End(xlUp).Row + 1
For Each ws In Worksheets
A = ws.Name
Select Case ws.Name
Case "Sheet1":
With ws
.UsedRange.AutoFilter Field:=1, Criteria1:="*"
.UsedRange.Offset(1, 0).Copy
dSht.Cells(dRow, 1).PasteSpecial xlPasteValues
.UsedRange.Offset(1, 0).SpecialCells(12).EntireRow.Delete
.UsedRange.AutoFilter
dRow = dSht.Range("A" & Rows.Count).End(xlUp).Row + 1
End With
End Select
Next ws
Application.ScreenUpdating = True
Beep
MsgBox "Data transfer complete", vbExclamation
End Sub


("Leelabird" took it to another forum to have a "Delete" line of code inserted because I couldn't work that one out!).

This code basically does what your above code does and works well but "leelabird" wanted an option to add more sheets at a later date and then be able to summarise all sheets to a "summary" sheet without having to worry about writing a new code. Hence the "Case" statement in the code. So by changing "Sheet2" to "Summary" and adding the extra sheet names to the "Case" statement, she should be able to do this (I think!). Code on standby mode!!

Hence, my query: is there any way of streamlining the code to make it look less "clumsy"? Your code above is really compact and robust and I'm hoping that perhaps you may know a way of doing the same for "leelabird's" situation.

I'll owe you some more "frothies" if you can help! ;-)

Again, my apologies for intruding.

Still learning.

Cheers,
vcoolio.
Posts
2829
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 22, 2021
490
Hi Vcoolio,

Hopefully you are doing great as well as your wife, who must love you even more now that your excel skills are growing, haha.


With the following code it doesn't matter if she adds more rows, columns, or sheets.
I changed Sheet2 to Summary, the other sheet names are irrelevant.

Here is the code:
Sub Copy()
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Integer

Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name = "Summary" Then GoTo NextSheet
    
    ws.Select
    
    lRow = Range("A" & Rows.Count).End(xlUp).Row
    lCol = Cells(1, Columns.Count).End(xlToLeft).Column
    
    For Each cell In Range("A2:A" & lRow)
        If cell.Value = "*" Then
            Range(Cells(cell.Row, "A"), Cells(cell.Row, lCol)).Copy
            Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Range(Cells(cell.Row, "A"), Cells(cell.Row, lCol)).ClearContents
        End If
    Next cell

    ws.UsedRange.Sort key1:=Range("A1"), Header:=xlYes

NextSheet:
Next ws

Sheets("Summary").Select

Application.ScreenUpdating = True

Beep

MsgBox "Data transfer complete", vbExclamation
End Sub


For an easier to read code, click on the arrow down next to the code button (the one on top of the message body) and select basic.


Let me know if I earned myself another frothie ;)

Best regards,
Trowa
Posts
1326
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
November 28, 2021
241
Greetings Trowa,

Doing well thanks but the wife is still in love with you! Its all your fault. You got me totally fascinated with Excel/VBA since helping me out with that rather complicated scenario of mine a few months ago. It certainly keeps the mind active. I can even concentrate better now to beat the computer at Chess!
I hope all is chugging along nicely for you also.

I think that I may have already told you that you are a genius. The amendment you made to my code above is just perfect and simplified it nicely. Now ims has another option. I'll pass it on to Leelabird.

Seems as if I'll have to buy you a brewery not just another frothie! Will the Heineken brewery do?

Many thanks Trowa and again my apologies to you and ims for hijacking this thread.

Cheers,
vcoolio.
Posts
2829
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 22, 2021
490
Hi Vcoolio,

You always make me feel really appreciated and now even loved!

Looking forward to the next situation where we can help each other out (I learned to make my computer beep by using Beep!)

I don't drink as much so a single frothie will do, haha.

Talk to you next time.

Cheers,
Trowa