Trigger and move most of the row

R

RattlingCarp3048

Board Regular
Joined
Jan 12, 2022
Messages
183
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
 
Sort by date Sort by votes
7 minutes ?
That must be immediately, a fraction of a second.
Are you trying with my attachment or with your's ?

Can you do "CTRL+Break" ?
 
Upvote 0

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
BSALV said:
7 minutes ?
That must be immediately, a fraction of a second.
Are you trying with my attachment or with your's ?

Can you do "CTRL+Break" ?
Click to expand...
I used both. Copied the edited event procedure and pasted over my original to ensure I didn't miss any of your modifications. That part worked just fine. Then inserted a new module and pasted your code. Then removed the ' because I do want to delete the original row after its been transferred. Let it run and force closed it after 15+ minutes because it was stuck in "not responding " mode.
 
Upvote 0
BSALV said:
7 minutes ?
That must be immediately, a fraction of a second.
Are you trying with my attachment or with your's ?

Can you do "CTRL+Break" ?
Click to expand...
I tried again this morning with the same results as yesterday. Here are a few screen shots. I updated the sheet names and removed the ' in order to delete the row after but everything else was a direct copy/paste. ctrl+break and escape do not work. When i update the employee status it triggers the event procedure to open a msgbx which is working exactly as planned. As soon as i click yes, on the msgbx i get the blue wheel, the screen flashes, then excel isnt responding and the screen turns white. escape and ctrl+break will not work and i have to force close and reopen.

1644589932806.png
1644590010334.png
 
Upvote 0
there isn't very much changed in ths macro for the normal module
you get a msgbox in the first line to be sure, you run this macro
the next loop can max have 3 loops and stops then
at the end, you get an idea of the elapsed time (fraction of a second).

VBA Code: 
Sub CopyData(rij As Long)
     MsgBox "new macro"                                         'to be sure you call this new macro

     t = Timer
     Set sh2 = Sheets("sheet2")                                 'your sheet2
     Set sh6 = Sheets("sheet6")                                 'your sheet6

     Do
          ptr = ptr + 1                                         'a pointer to know how many loops
          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 And ptr < 3                        'normally 1 (no columns inserted) or 2 loops (at least 1 column inserted
     If ptr >= 3 Then MsgBox "inpossible, ptr can never be >=3": Exit Sub

     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

     MsgBox "done in " & Timer - t & " sec"
End Sub
 
Upvote 0
BSALV said:
there isn't very much changed in ths macro for the normal module
you get a msgbox in the first line to be sure, you run this macro
the next loop can max have 3 loops and stops then
at the end, you get an idea of the elapsed time (fraction of a second).

VBA Code: 
Sub CopyData(rij As Long)
     MsgBox "new macro"                                         'to be sure you call this new macro

     t = Timer
     Set sh2 = Sheets("sheet2")                                 'your sheet2
     Set sh6 = Sheets("sheet6")                                 'your sheet6

     Do
          ptr = ptr + 1                                         'a pointer to know how many loops
          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 And ptr < 3                        'normally 1 (no columns inserted) or 2 loops (at least 1 column inserted
     If ptr >= 3 Then MsgBox "inpossible, ptr can never be >=3": Exit Sub

     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

     MsgBox "done in " & Timer - t & " sec"
End Sub
Click to expand...
this returned in seconds...

1644591755564.png
 
Upvote 0
BSALV said:
there isn't very much changed in ths macro for the normal module
you get a msgbox in the first line to be sure, you run this macro
the next loop can max have 3 loops and stops then
at the end, you get an idea of the elapsed time (fraction of a second).

VBA Code: 
Sub CopyData(rij As Long)
     MsgBox "new macro"                                         'to be sure you call this new macro

     t = Timer
     Set sh2 = Sheets("sheet2")                                 'your sheet2
     Set sh6 = Sheets("sheet6")                                 'your sheet6

     Do
          ptr = ptr + 1                                         'a pointer to know how many loops
          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 And ptr < 3                        'normally 1 (no columns inserted) or 2 loops (at least 1 column inserted
     If ptr >= 3 Then MsgBox "inpossible, ptr can never be >=3": Exit Sub

     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

     MsgBox "done in " & Timer - t & " sec"
End Sub
Click to expand...
Any thoughts on next steps?
 
Upvote 0
Rattling.xlsm
i just added a lot of msgboxes in a way to detect the problem.
1st loop of the macro you have the original number of columns for both sheets.
2nd loop of the macro, the same number for summary and the number for archive is higher in case of adding columns
there may never be a 3rd loop

When everything is running okay, make in 1st line bquick=false to avoid all those msgboxes.
VBA Code: 
Sub CopyData(rij As Long)

     '********************************************************************************************
     bquick = False                                              '--------------> MAKE THIS VARIABLE TRUE(=TESTING) OR FALSE(NORMAL)
     '********************************************************************************************

     If Not bquick Then MsgBox "new macro"                      'to be sure you call this new macro

     t = Timer
     Set sh2 = Sheets("Summary")                                'your sheet2
     Set sh6 = Sheets("Archived Employee Data")                 'your sheet6

     Do
          ptr = ptr + 1                                         'a pointer to know how many loops
          btest = False                                         'flag no columns added
          a = sh2.Range("A1").CurrentRegion.Resize(3)           'read 1st 2 rows of sheet2 = header + 1st datarow
          b = sh6.Range("A1").CurrentRegion.Resize(1)           'read 1 row of sheet6 = header
          If Not bquick Then MsgBox "at start loop : " & ptr & vbLf & sh2.Name & " and " & sh6.Name & " have " & UBound(a, 2) & " and " & UBound(b, 2) & " columns"

          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
               a(3, k) = a(1, k) & "    " & a(2, k)
          Next

          If Not bquick Then
               MsgBox "columns " & sh2.Name & vbLf & "name and columnnumber" & vbLf & vbLf & Join(Application.Index(a, 3, 0), vbLf)
               Application.Goto sh6.Range("A1")
               MsgBox "columns " & sh6.Name & vbLf & vbLf & Join(Application.Transpose(Application.Transpose(b)), vbLf)
          End If

     Loop While btest = True And ptr < 3                        'normally 1 (no columns inserted) or 2 loops (at least 1 column inserted
     If ptr >= 3 Then MsgBox "inpossible, ptr can never be >=3": Exit Sub

     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

     MsgBox "transferred in " & Format(Timer - t, "0.00") & " sec"
End Sub
 
Upvote 0
BSALV said:
Rattling.xlsm
i just added a lot of msgboxes in a way to detect the problem.
1st loop of the macro you have the original number of columns for both sheets.
2nd loop of the macro, the same number for summary and the number for archive is higher in case of adding columns
there may never be a 3rd loop

When everything is running okay, make in 1st line bquick=false to avoid all those msgboxes.
VBA Code: 
Sub CopyData(rij As Long)

     '********************************************************************************************
     bquick = False                                              '--------------> MAKE THIS VARIABLE TRUE(=TESTING) OR FALSE(NORMAL)
     '********************************************************************************************

     If Not bquick Then MsgBox "new macro"                      'to be sure you call this new macro

     t = Timer
     Set sh2 = Sheets("Summary")                                'your sheet2
     Set sh6 = Sheets("Archived Employee Data")                 'your sheet6

     Do
          ptr = ptr + 1                                         'a pointer to know how many loops
          btest = False                                         'flag no columns added
          a = sh2.Range("A1").CurrentRegion.Resize(3)           'read 1st 2 rows of sheet2 = header + 1st datarow
          b = sh6.Range("A1").CurrentRegion.Resize(1)           'read 1 row of sheet6 = header
          If Not bquick Then MsgBox "at start loop : " & ptr & vbLf & sh2.Name & " and " & sh6.Name & " have " & UBound(a, 2) & " and " & UBound(b, 2) & " columns"

          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
            [COLOR=rgb(250, 197, 28)]  [B] a(3, k) = a(1, k) & "    " & a(2, k)[/B][/COLOR]
          Next

          If Not bquick Then
               MsgBox "columns " & sh2.Name & vbLf & "name and columnnumber" & vbLf & vbLf & Join(Application.Index(a, 3, 0), vbLf)
               Application.Goto sh6.Range("A1")
               MsgBox "columns " & sh6.Name & vbLf & vbLf & Join(Application.Transpose(Application.Transpose(b)), vbLf)
          End If

     Loop While btest = True And ptr < 3                        'normally 1 (no columns inserted) or 2 loops (at least 1 column inserted
     If ptr >= 3 Then MsgBox "inpossible, ptr can never be >=3": Exit Sub

     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

     MsgBox "transferred in " & Format(Timer - t, "0.00") & " sec"
End Sub
Click to expand...
Error... debug type mismatch shows what i highlighted in yellow.
 
Upvote 0
i see nothing in yellow.
Do you use "option explicit" somewhere ?
 
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
544
ItsNursinTime
I
M
  • Solved
Copy and paste multiple matching rows to a new sheet
Replies
7
Views
255
SamKhem
S
A
  • Question
Insert new column(DATE) up to finish month and move to next sheet
Replies
0
Views
161
Amer Omar
A
I
  • Question
Delete customers row of values after my code has completed moving its copy
2
Replies
17
Views
245
ipbr21054
I
T
  • Question
Sort Sheet By Date
2
Replies
11
Views
297
Alex Blakenburg
A

Forum statistics

Threads
1,216,178
Messages
6,129,327
Members
449,502
Latest member
TSH8125

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