CODEWITHSUNDEEP
vbaexcel
Jon white
Jon white

Reputation: 11

VBA paste new values in column B of sheet 1 to last empty cell of B in sheet2

Think of my problem like this: cells FS3:FS33 show customer receipts for customers in the restaurant seats 3 to 33 ( those are the only seats ) at the present time. As they leave their receipts leave the cells FS3:FS33 and go to the bin. New customers come and go and as they come and go FS3:FS33 fills downwards to the last column ( ie there will be no gaps and they will fill from FS3 down ). Each receipt is unique and needs to be recorded and kept on the last empty row of another column on a different sheet in C:C.

This Q has been answered but I have one final problem with it not updating - see below

the combination of this sub in a module

Sub hithere3()
Dim Rng As Range
Dim Unique As Boolean

For Each Rng In Worksheets("Sheet8").Range("FS3:FS30") 'for each cell     in     your B1 to B30 range, sheet1
Unique = True 'we'll assume it's unique
Lastunique = Worksheets("TRADES").Range("C:C").Find("*",     SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 3 To Lastunique 'for each cell in the unique ID cache
    If Rng.Value = Worksheets("TRADES").Cells(i, 3).Value Then 'we       check    if it is equal
        Unique = False 'if yes, it is not unique
    End If
Next
If Unique Then Worksheets("TRADES").Cells(Lastunique + 1, 3) = Rng 'adds    if it is unique
Next
End Sub

with the loop check in a worksheet change events

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("FS3:FS33")) Is Nothing Then
'Do nothing '
Else
Call hithere3
End If
End Sub

works except it only updates when I select one of the cells in FS3:FS33

Can anyone suggest how this can be overcome?

SOLUTION 

Private Sub Worksheet_calculate()
If Range("FS3:FS33") Is Nothing Then
'Do nothing'
Else
 Call hithere3
End If
End Sub

Upvotes: 0

Views: 441

Answers (2)

Mark Moore
Mark Moore

Reputation: 510

Adding as an answer because comments wont let me format the code section properly. Jon am assuming you are using the code above from user3819867, all you need to do to use the intersect is change the worksheet_change module to be Private Sub WorkSheet_Change(ByVal Target As Range) If Intersect(Target, Range("B1:B30")) Is Nothing Then 'Do nothing ' else Call ertdfgcvb end if End Sub

edited to add that I dont really see a need to call a seperate procedure here. Would put the procedure code directly in here as its quite small, plus makes it easier to read if you decide to tweak and use "target" instead

Upvotes: 1

user3819867
user3819867

Reputation: 1120

I made a simple solution for you. If your datasets are relatively small, it will take no time to run it on each value input (Worksheet_Change event).

Sub ertdfgcvb()
Dim rng As Range
Dim Unique As Boolean

For Each rng In Worksheets("Sheet1").Range("B1:B30") 'for each cell in your B1 to B30 range, sheet1
    Unique = True 'we'll assume it's unique
    Lastunique = Worksheets("Sheet2").Range("B:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For i = 1 To Lastunique 'for each cell in the unique ID cache
        If rng.Value = Worksheets("Sheet2").Cells(i, 2).Value Then 'we check if it is equal
            Unique = False 'if yes, it is not unique
        End If
    Next
    If Unique Then Worksheets("Sheet2").Cells(Lastunique + 1, 2) = rng 'adds if it is unique
Next
End Sub

The call will look like:

Private Sub WorkSheet_Change(ByVal Target As Range)
Call ertdfgcvb
End Sub

If you have larger datasets, you will have to refer to Target instead.

Upvotes: 0

Related Questions