Trigger and move most of the row

R

RattlingCarp3048

Board Regular
Joined
Jan 12, 2022
Messages
166
Office Version
  1. 365
Platform
  1. Windows
I found a similar post related to what I am trying to accomplish but it didnt work for me, thought you guys might be able to help out. Id like to create a trigger so that anytime a user changes the drop down list in column B to "water" or "food" it will automatically move the row from sheet 2 to sheet 6 next available row. heres the thing, i dont need to move the entire row, just most of it and insert any missing column headers.

i dont really have a VBA code started as nothing has worked so far.

From sheet 2: Copy A-D and Z-last column
On sheet 6: paste A-D (same headers), insert missing column headers, and match/paste Z-last column from sheet 2 into the matching column on sheet 6.

in this example, column headers Z-AA-AB are missing from sheet 6 so they need to be inserted before pasting the data
1644342316657.png


1644342329044.png
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Sort by date Sort by votes
bump

I figured out how to create the trigger/event as a VBA code, what i am still stuck on is a code that compares the column headers and inserts the missing ones. Help!
 
Upvote 0
can you add some lines of data for sheet2 and sheet6 with the XL2BB-tool ?
 
Upvote 0
this is the macro to copy from sheet2 to sheet6
VBA Code: 
Option compare text
Sub CopyData()
     Set sh2 = Sheets("sheet2")                                 'your sheet2
     Set sh6 = Sheets("sheet6")                                 'your sheet6

     Do
          btest = False                                         'flag no columns added
          a = sh2.Range("A1").CurrentRegion.Resize(2)           'read 1st 2 rows of sheet2 = header + 1st datarow
          b = sh6.Range("A1").CurrentRegion.Resize(1)           'read 1 row of sheet6 = header
          For k = UBound(a, 2) To 1 Step -1                     'loop from last column to 1st column of sheet2
               k1 = Application.Match(a(1, k), b, 0)            'check if header also exists in sheet6
               If Not IsNumeric(k1) Then                        'if not
                    sh6.Range("E1").EntireColumn.Insert         'insert new column in E
                    sh6.Range("E1").Value = a(1, k)             'new headername
                    btest = True                                'flag new column added
               End If
               a(2, k) = k1                                     'replace the 2nd row with the corresponding column in sheet6
          Next
     Loop While btest = True                                    'normally 1 (no columns inserted) or 2 loops (at least 1 column inserted
     imax = Application.Max(Application.Index(a, 2, 0))         'the max corresponding column number in sheet6

     Set dict = CreateObject("scripting.dictionary")            'use a dictionary
     arr = sh2.Range("A1").CurrentRegion                        'read data into an array
     For r = 2 To UBound(arr)                                   'loop from 2nd to last row
       if arr(r,2)="water" or arr(r,2)="food" then          
       ReDim arr1(1 To imax)                                 'clear aux. array
          For k = 1 To UBound(arr, 2)                           'loop from 1st to last column of sheet2
               arr1(a(2, k)) = arr(r, k)                        'fill aux. array in the right element
          Next
          dict.Add dict.Count, arr1                             'add aux.array to dictionary
          endif    
 Next

     If dict.Count > 0 Then sh6.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(dict.Count, imax).Value = Application.Index(dict.items, 0)     'if there is data, add it to sheet6
End Sub
 
Upvote 0
BSALV said:
this is the macro to copy from sheet2 to sheet6
VBA Code: 
Option compare text
Sub CopyData()
     Set sh2 = Sheets("sheet2")                                 'your sheet2
     Set sh6 = Sheets("sheet6")                                 'your sheet6

     Do
          btest = False                                         'flag no columns added
          a = sh2.Range("A1").CurrentRegion.Resize(2)           'read 1st 2 rows of sheet2 = header + 1st datarow
          b = sh6.Range("A1").CurrentRegion.Resize(1)           'read 1 row of sheet6 = header
          For k = UBound(a, 2) To 1 Step -1                     'loop from last column to 1st column of sheet2
               k1 = Application.Match(a(1, k), b, 0)            'check if header also exists in sheet6
               If Not IsNumeric(k1) Then                        'if not
                    sh6.Range("E1").EntireColumn.Insert         'insert new column in E
                    sh6.Range("E1").Value = a(1, k)             'new headername
                    btest = True                                'flag new column added
               End If
               a(2, k) = k1                                     'replace the 2nd row with the corresponding column in sheet6
          Next
     Loop While btest = True                                    'normally 1 (no columns inserted) or 2 loops (at least 1 column inserted
     imax = Application.Max(Application.Index(a, 2, 0))         'the max corresponding column number in sheet6

     Set dict = CreateObject("scripting.dictionary")            'use a dictionary
     arr = sh2.Range("A1").CurrentRegion                        'read data into an array
     For r = 2 To UBound(arr)                                   'loop from 2nd to last row
       if arr(r,2)="water" or arr(r,2)="food" then         
       ReDim arr1(1 To imax)                                 'clear aux. array
          For k = 1 To UBound(arr, 2)                           'loop from 1st to last column of sheet2
               arr1(a(2, k)) = arr(r, k)                        'fill aux. array in the right element
          Next
          dict.Add dict.Count, arr1                             'add aux.array to dictionary
          endif   
 Next

     If dict.Count > 0 Then sh6.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(dict.Count, imax).Value = Application.Index(dict.items, 0)     'if there is data, add it to sheet6
End Sub
Click to expand...
Would i add this code to the same module as the event procedure? or would this go on a separate module?
 
Upvote 0
BSALV said:
this is the macro to copy from sheet2 to sheet6
VBA Code: 
Option compare text
Sub CopyData()
     Set sh2 = Sheets("sheet2")                                 'your sheet2
     Set sh6 = Sheets("sheet6")                                 'your sheet6

     Do
          btest = False                                         'flag no columns added
          a = sh2.Range("A1").CurrentRegion.Resize(2)           'read 1st 2 rows of sheet2 = header + 1st datarow
          b = sh6.Range("A1").CurrentRegion.Resize(1)           'read 1 row of sheet6 = header
          For k = UBound(a, 2) To 1 Step -1                     'loop from last column to 1st column of sheet2
               k1 = Application.Match(a(1, k), b, 0)            'check if header also exists in sheet6
               If Not IsNumeric(k1) Then                        'if not
                    sh6.Range("E1").EntireColumn.Insert         'insert new column in E
                    sh6.Range("E1").Value = a(1, k)             'new headername
                    btest = True                                'flag new column added
               End If
               a(2, k) = k1                                     'replace the 2nd row with the corresponding column in sheet6
          Next
     Loop While btest = True                                    'normally 1 (no columns inserted) or 2 loops (at least 1 column inserted
     imax = Application.Max(Application.Index(a, 2, 0))         'the max corresponding column number in sheet6

     Set dict = CreateObject("scripting.dictionary")            'use a dictionary
     arr = sh2.Range("A1").CurrentRegion                        'read data into an array
     For r = 2 To UBound(arr)                                   'loop from 2nd to last row
       if arr(r,2)="water" or arr(r,2)="food" then         
       ReDim arr1(1 To imax)                                 'clear aux. array
          For k = 1 To UBound(arr, 2)                           'loop from 1st to last column of sheet2
               arr1(a(2, k)) = arr(r, k)                        'fill aux. array in the right element
          Next
          dict.Add dict.Count, arr1                             'add aux.array to dictionary
          endif   
 Next

     If dict.Count > 0 Then sh6.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(dict.Count, imax).Value = Application.Index(dict.items, 0)     'if there is data, add it to sheet6
End Sub
Click to expand...
this is what i have so far which takes care of the trigger/msgbx aspect. How would i connect it with yours to test? If the user selects "Yes" in the msgbx i want it to run your code.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Row > 1 And Target.Value = "Inactive" Or Target.Value = "Transferred" Then
Ans = MsgBox("Changing the employee status to Inactive or Transferred will archive their historical data. Are you sure you want to archive the employee?", vbYesNo)
End If
If Ans = vbNo Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End Sub
 
Upvote 0
BSALV said:
this is the macro to copy from sheet2 to sheet6
VBA Code: 
Option compare text
Sub CopyData()
     Set sh2 = Sheets("sheet2")                                 'your sheet2
     Set sh6 = Sheets("sheet6")                                 'your sheet6

     Do
          btest = False                                         'flag no columns added
          a = sh2.Range("A1").CurrentRegion.Resize(2)           'read 1st 2 rows of sheet2 = header + 1st datarow
          b = sh6.Range("A1").CurrentRegion.Resize(1)           'read 1 row of sheet6 = header
          For k = UBound(a, 2) To 1 Step -1                     'loop from last column to 1st column of sheet2
               k1 = Application.Match(a(1, k), b, 0)            'check if header also exists in sheet6
               If Not IsNumeric(k1) Then                        'if not
                    sh6.Range("E1").EntireColumn.Insert         'insert new column in E
                    sh6.Range("E1").Value = a(1, k)             'new headername
                    btest = True                                'flag new column added
               End If
               a(2, k) = k1                                     'replace the 2nd row with the corresponding column in sheet6
          Next
     Loop While btest = True                                    'normally 1 (no columns inserted) or 2 loops (at least 1 column inserted
     imax = Application.Max(Application.Index(a, 2, 0))         'the max corresponding column number in sheet6

     Set dict = CreateObject("scripting.dictionary")            'use a dictionary
     arr = sh2.Range("A1").CurrentRegion                        'read data into an array
     For r = 2 To UBound(arr)                                   'loop from 2nd to last row
       if arr(r,2)="water" or arr(r,2)="food" then         
       ReDim arr1(1 To imax)                                 'clear aux. array
          For k = 1 To UBound(arr, 2)                           'loop from 1st to last column of sheet2
               arr1(a(2, k)) = arr(r, k)                        'fill aux. array in the right element
          Next
          dict.Add dict.Count, arr1                             'add aux.array to dictionary
          endif   
 Next

     If dict.Count > 0 Then sh6.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(dict.Count, imax).Value = Application.Index(dict.items, 0)     'if there is data, add it to sheet6
End Sub
Click to expand...
I dont think this works. I have the event procedure created yes, and realized the event procedure module is not the same as a regular module (i knew that, lol). So i inserted a new module, pasted your code and attempted to run it independently of the event procedure in order to test it out. unfortunately it timed out, then it crashed excel, then it just ran with no errors until i force closed it myself, then it bugged with this row of code... sh6.Range("E1").EntireColumn.Insert 'insert new column in E....

im at a loss :(
 
Upvote 0
Rattling.xlsm
you copy only 1 line every time, so there is no need for a dictionary.
If you want to delete that line in sheet2, delete that '-character in front of
VBA Code: 
 'sh2.Rows(rij).Delete                                       'you want to delete that row ????
this is the macro in a normal module
VBA Code: 
Sub CopyData(rij As Long)
     Set sh2 = Sheets("sheet2")                                 'your sheet2
     Set sh6 = Sheets("sheet6")                                 'your sheet6

     Do
          btest = False                                         'flag no columns added
          a = sh2.Range("A1").CurrentRegion.Resize(2)           'read 1st 2 rows of sheet2 = header + 1st datarow
          b = sh6.Range("A1").CurrentRegion.Resize(1)           'read 1 row of sheet6 = header
          For k = UBound(a, 2) To 1 Step -1                     'loop from last column to 1st column of sheet2
               k1 = Application.Match(a(1, k), b, 0)            'check if header also exists in sheet6
               If Not IsNumeric(k1) Then                        'if not
                    sh6.Range("E1").EntireColumn.Insert         'insert new column in E
                    sh6.Range("E1").Value = a(1, k)             'new headername
                    btest = True                                'flag new column added
               End If
               a(2, k) = k1                                     'replace the 2nd row with the corresponding column in sheet6
          Next
     Loop While btest = True                                    'normally 1 (no columns inserted) or 2 loops (at least 1 column inserted
     imax = Application.Max(Application.Index(a, 2, 0))         'the max corresponding column number in sheet6

     arr = sh2.Range("A1").CurrentRegion                        'read data into an array
     ReDim arr1(1 To imax)                                      'clear aux. array
     For k = 1 To UBound(arr, 2)                                'loop from 1st to last column of sheet2
          arr1(a(2, k)) = arr(rij, k)                           'fill aux. array in the right element
     Next

     sh6.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, imax).Value = arr1     ' Application.Index(dict.items, 0)     'if there is data, add it to sheet6
     Application.EnableEvents = False
     'sh2.Rows(rij).Delete                                       'you want to delete that row ????
     Application.EnableEvents = True

End Sub
and this is the macro in your sheetmodule
VBA Code: 
Option Compare Text                                             'this sheet isn't case sensitive

Private Sub Worksheet_Change(ByVal Target As Range)
     If Target.Column = 3 And Target.Row > 1 And (Target.Value = "Inactive" Or Target.Value = "Transferred") Then
          Ans = MsgBox("Changing the employee status to Inactive or Transferred will archive their historical data. Are you sure you want to archive the employee?", vbYesNo)
          If Ans = vbNo Then
               Application.EnableEvents = False
               Application.Undo
               Application.EnableEvents = True
          Else
               CopyData Target.Row                              'only this row
          End If
     End If
End Sub
 
Last edited:
Upvote 0
BSALV said:
Rattling.xlsm
you copy only 1 line every time, so there is no need for a dictionary.
If you want to delete that line in sheet2, delete that '-character in front of
VBA Code: 
 'sh2.Rows(rij).Delete                                       'you want to delete that row ????
this is the macro in a normal module
VBA Code: 
Sub CopyData(rij As Long)
     Set sh2 = Sheets("sheet2")                                 'your sheet2
     Set sh6 = Sheets("sheet6")                                 'your sheet6

     Do
          btest = False                                         'flag no columns added
          a = sh2.Range("A1").CurrentRegion.Resize(2)           'read 1st 2 rows of sheet2 = header + 1st datarow
          b = sh6.Range("A1").CurrentRegion.Resize(1)           'read 1 row of sheet6 = header
          For k = UBound(a, 2) To 1 Step -1                     'loop from last column to 1st column of sheet2
               k1 = Application.Match(a(1, k), b, 0)            'check if header also exists in sheet6
               If Not IsNumeric(k1) Then                        'if not
                    sh6.Range("E1").EntireColumn.Insert         'insert new column in E
                    sh6.Range("E1").Value = a(1, k)             'new headername
                    btest = True                                'flag new column added
               End If
               a(2, k) = k1                                     'replace the 2nd row with the corresponding column in sheet6
          Next
     Loop While btest = True                                    'normally 1 (no columns inserted) or 2 loops (at least 1 column inserted
     imax = Application.Max(Application.Index(a, 2, 0))         'the max corresponding column number in sheet6

     arr = sh2.Range("A1").CurrentRegion                        'read data into an array
     ReDim arr1(1 To imax)                                      'clear aux. array
     For k = 1 To UBound(arr, 2)                                'loop from 1st to last column of sheet2
          arr1(a(2, k)) = arr(rij, k)                           'fill aux. array in the right element
     Next

     sh6.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, imax).Value = arr1     ' Application.Index(dict.items, 0)     'if there is data, add it to sheet6
     Application.EnableEvents = False
     'sh2.Rows(rij).Delete                                       'you want to delete that row ????
     Application.EnableEvents = True

End Sub
and this is the macro in your sheetmodule
VBA Code: 
Option Compare Text                                             'this sheet isn't case sensitive

Private Sub Worksheet_Change(ByVal Target As Range)
     If Target.Column = 3 And Target.Row > 1 And (Target.Value = "Inactive" Or Target.Value = "Transferred") Then
          Ans = MsgBox("Changing the employee status to Inactive or Transferred will archive their historical data. Are you sure you want to archive the employee?", vbYesNo)
          If Ans = vbNo Then
               Application.EnableEvents = False
               Application.Undo
               Application.EnableEvents = True
          Else
               CopyData Target.Row                              'only this row
          End If
     End If
End Sub
Click to expand...
its been "running" about 7-ish minutes so far. no error or time outs.
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question
Move multiple rows from one table to another using conditional trigger
Replies
2
Views
482
ItsNursinTime
I
M
  • Solved
Copy and paste multiple matching rows to a new sheet
Replies
6
Views
107
Multim
M
A
  • Question
Insert new column(DATE) up to finish month and move to next sheet
Replies
0
Views
132
Amer Omar
A
T
  • Question
Sort Sheet By Date
2
Replies
11
Views
247
Alex Blakenburg
A
W
  • Question
SCHEDULE DASHBOARD VBA CODE (AUTOMATCICALLY TOGGLE TO MATCHING COLUMN)
Replies
0
Views
88
Willkim
W

Forum statistics

Threads
1,215,220
Messages
6,123,693
Members
449,117
Latest member
Aaagu

Share this page

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