Help with Worksheet change macro

Cruiser69

Board Regular
Joined
Mar 12, 2018
Messages
61
Office Version
  1. 365
Platform
  1. Windows
Hi again.

I've got another question for you all.

In Column A there are Part Codes separated by a blank line. Column B are the Vendor codes which are pasted in each time

Column AColumn B
Part Code1Vendor Codes
A1CCC
DDD
B1EEE
FFF
C1



Is it possible after the codes are pasted into column B, extra rows are added as below and the Part Code 1 codes are duplicated. Then when codes are added for Part code B1, the same happens again

Column AColumn B
Part Code1Vendor Codes
A1CCC
A1DDD
A1EEE
A1FFF

B1

C1



Hope this makes sense.

Thanks for looking,



Graham
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
When you say Vendor codes are pasted in are the done in one group or one at a time?
 
Upvote 0
Try
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim lr As Long
Dim ir As Long
Dim trow As Long
Dim pcode As String
Dim rng As Range
Dim endrow As Long
Dim myary As Variant
Dim rngtext As String

lr = Cells(Rows.Count, 1).End(xlUp).Row
trow = Target.Row
rngtext = Target.Address


If Target.Column = 2 Then

    endrow = Range(Mid(Target.Address, InStr(Target.Address, ":") + 1, 9999999)).Row
    Application.EnableEvents = False
    Set rng = Range(Target.Address)
    
    'find part code
    If Cells(trow, 1) <> "" Then
        pcode = Cells(trow, 1)
    Else
        pcode = Cells(trow, 1).End(xlUp).Value
    End If
    
    'find row of next part code
    For Each c In Range("A" & trow & ":A" & lr)
        If c <> pcode And c <> "" Then
            ir = c.Row
            Exit For
        End If
    Next c
    
      'insert rows if need
    If ir - 1 <= endrow And lr > endrow Then
    
        'put pasted values in array so it is not moved when inserting rows
        myary = rng.Value
        rng.ClearContents
        Range(Cells(ir, 1), Cells(endrow + 1, 1)).EntireRow.Insert
        Set rng = Range(rngtext)
        rng.Value = myary
    End If
    
    'insert part code in col A
    For Each cell In rng
        If cell.Offset(0, -1) = "" Then cell.Offset(0, -1) = pcode
    Next cell
      
    Application.EnableEvents = True
End If


End Sub
 
Upvote 0
Hi Steve.

Thanks for you reply.

I'm having difficulties with it.

It only seems to work on the first time. Nothing happens the second time I paste in.

Another problem I didn't mention is that some of the part codes have underscores in them. Is this a problem.

Thanks again

Graham
 
Upvote 0
Are you getting any error message?

Since the code runs when a change is made and the code makes changes the code turns off events so it is not triggered again when it makes changes to the sheet. If the code does not run all the way though due to an error then events will not be turned back on.

Put this in the immediate window of the VBA editor and hit enter to make sure events are turned on.
VBA Code:
Application.EnableEvents = True

Underscores should not cause any problems.
 
Upvote 0
Hi Steve.
The first copy and paste will work no problem.
If I manually enter vendor codes it works.
If I copy two vendor codes at a time it will still work.
More than 3 does not seem to work properly.

Graham
 
Upvote 0
Try
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim lr As Long
Dim ir As Long
Dim trow As Long
Dim pcode As String
Dim rng As Range
Dim endrow As Long
Dim myary As Variant
Dim rngtext As String

lr = Cells(Rows.Count, 1).End(xlUp).Row
trow = Target.Row
rngtext = Target.Address


If Target.Column = 2 Then

    endrow = Range(Mid(Target.Address, InStr(Target.Address, ":") + 1, 9999999)).Row
    Application.EnableEvents = False
    Set rng = Range(Target.Address)
    
    'find part code
    If Cells(trow, 1) <> "" Then
        pcode = Cells(trow, 1)
    Else
        pcode = Cells(trow, 1).End(xlUp).Value
    End If
    
    'find row of next part code
    For Each c In Range("A" & trow & ":A" & lr)
        If c <> pcode And c.Row <> endrow And c <> "" Then
            ir = c.Row
            Exit For
        End If
    Next c
    'set row if last product code
    If ir = 0 Then ir = trow
    
    'insert rows if need
    If pcode <> Cells(ir, 1) Then
    
        'put pasted values in array so it is not moved when inserting rows
        myary = rng.Value
        rng.ClearContents
        Range(Cells(ir, 1), Cells(endrow + 1, 1)).EntireRow.Insert
        Set rng = Range(rngtext)
        rng.Value = myary
    End If
    
    'insert part code in col A
    For Each cell In rng
        If cell.Offset(0, -1) = "" Then cell.Offset(0, -1) = pcode
    Next cell
      
    Application.EnableEvents = True
End If

End Sub
 
Upvote 0
Hi Steve.
That works great. Thanks a lot for this.
One more question. If I wanted to change the Part Code to Column C and Vendor Code to Column D is that an easy fix.


Regards.

Graham
 
Upvote 0
This will look at column C and D.
I also found a problem where if the data pasted in happened to end on the same row of last part code the code would not work as intended.


Code:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim lr As Long
Dim ir As Long
Dim trow As Long
Dim pcode As String
Dim rng As Range
Dim endrow As Long
Dim myary As Variant
Dim rngtext As String

lr = Cells(Rows.Count, 3).End(xlUp).Row
trow = Target.Row
rngtext = Target.Address


If Target.Column = 4 Then

    endrow = Range(Mid(Target.Address, InStr(Target.Address, ":") + 1, 9999999)).Row
    Application.EnableEvents = False
    Set rng = Range(Target.Address)
    
    'find part code
    If Cells(trow, 3) <> "" Then
        pcode = Cells(trow, 3)
    Else
        pcode = Cells(trow, 3).End(xlUp).Value
    End If
    
    'find row of next part code
    For Each c In Range("C" & trow & ":C" & lr)
        If c <> pcode And c <> "" Then
            ir = c.Row
            Exit For
        End If
    Next c
    'set row if last product code
    If ir = 0 And ir <> endrow Then ir = trow
    
    
    'insert rows if need
    If pcode <> Cells(ir, 3) Then
    
        'put pasted values in array so it is not moved when inserting rows
        myary = rng.Value
        rng.ClearContents
        Range(Cells(ir, 3), Cells(endrow + 1, 3)).EntireRow.Insert
        Set rng = Range(rngtext)
        rng.Value = myary
    End If
    
    'insert part code in col C
    For Each cell In rng
        If cell.Offset(0, -1) = "" Then cell.Offset(0, -1) = pcode
    Next cell
      
    Application.EnableEvents = True
End If

End Sub
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,186
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top