Trigger and move most of the row

[RattlingCarp3048]

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

 

[RattlingCarp3048]

is this what you are trying to say? the formatting came through a little mixed up.

Sub CopyData(rij As Long)

'********************************************************************************************
bquick = True '--------------> 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

sh2_LastColumn = sh2.Cells(1, Columns.Count).End(xlToLeft).Column
a = sh2.Range("A1").CurrentRegion.Resize(3, sh2_LastColumn) 'read 1st 2 rows of sheet2 = header + 1st datarow
b = sh6.Range("A" & Rows.Count).End(xlUp).Offset(1).Reseize(2, imax).Value = arr1 '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
If Len(a(1, k)) = 0 Then MsgBox "empty header in column " & Cells(1, k).Address & "!!!"
k1 = "new" 'check if header also exists in sheet6
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 bquick Then
'Sheets("BSALV").Range("A" & Rows.Count).End(xlUp).Offset(2).Resize(UBound(a), UBound(a, 2)).Value = a
Application.Goto sh6.Range("A1")
'Sheets("BSALV").Range("A" & Rows.Count).End(xlUp).Offset(2).Resize(UBound(b), UBound(b, 2)).Value = b
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.UsedRange.Resize(, UBound(a, 2)).Value 'read data into an array
ReDim arr1(1 To 2, 1 To imax) 'clear aux. array
For k = 1 To UBound(arr, 2) 'loop from 1st to last column of sheet2
arr1(1, a(2, k)) = arr(rij, k) 'fill aux. array in the right element
arr1(2, a(2, k)) = arr(1, k) 'fill aux. array in the right element
Next

sh6.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(2, imax).Value = arr1 ' --------> CHANGE LATER RESIZE(2,...) INTO RESIZE(1,....) '2nd line is the header
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

 

[BSALV]

so, what's the message ?

 

[RattlingCarp3048]

so, what's the message ?

if i run this......

Sub CopyData(rij As Long)

'********************************************************************************************
bquick = True '--------------> 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

sh2_LastColumn = sh2.Cells(1, Columns.Count).End(xlToLeft).Column
a = sh2.Range("A1").CurrentRegion.Resize(3, sh2_LastColumn) 'read 1st 2 rows of sheet2 = header + 1st datarow
b = sh6.Range("A" & Rows.Count).End(xlUp).Offset(1).Reseize(2, imax).Value = arr1 '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
If Len(a(1, k)) = 0 Then MsgBox "empty header in column " & Cells(1, k).Address & "!!!"
k1 = "new" 'check if header also exists in sheet6
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 bquick Then
'Sheets("BSALV").Range("A" & Rows.Count).End(xlUp).Offset(2).Resize(UBound(a), UBound(a, 2)).Value = a
Application.Goto sh6.Range("A1")
'Sheets("BSALV").Range("A" & Rows.Count).End(xlUp).Offset(2).Resize(UBound(b), UBound(b, 2)).Value = b
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.UsedRange.Resize(, UBound(a, 2)).Value 'read data into an array
ReDim arr1(1 To 2, 1 To imax) 'clear aux. array
For k = 1 To UBound(arr, 2) 'loop from 1st to last column of sheet2
arr1(1, a(2, k)) = arr(rij, k) 'fill aux. array in the right element
arr1(2, a(2, k)) = arr(1, k) 'fill aux. array in the right element
Next

sh6.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(2, imax).Value = arr1 ' --------> CHANGE LATER RESIZE(2,...) INTO RESIZE(1,....) '2nd line is the header
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




this line.... a(3, k) = a(1, k) & " " & a(2, k).... is still giving a run-time error 13 type mismatch

 

[RattlingCarp3048]

so, what's the message ?

question..... nothing we have tried seems to be working with the live data, even direct copy/pastes of the code. it seems every alteration to the code seems to be hanging up with the same line of code. is there another route we could go that might be a little easier to code? maybe the event procedure triggers the target row to hide? or maybe send an email to a specific person to just continue to do this manually, is excel sending an email even possible?

moving the row to another tab via macro was just a bucket list item and really doesn't take very much time to accomplish manually. this whole process has been very educational for me, however, i also did not expect it to be this complicated and seems as though i should be looking for an easier solution.

 

[BSALV]

i agree to disagree.
The macro i gave works at my side with the given worksheets.

In the last version there were a lot of duplicate columns ... .
It isn't written that difficult, there were no columns to be inserted (the most difficult part), so there was even no 2nd loop needed.
I 'll give it another try with lots of explanation at the right side, delete all unnecessary stuff, etc

 

[RattlingCarp3048]

i agree to disagree.
The macro i gave works at my side with the given worksheets.

In the last version there were a lot of duplicate columns ... .
It isn't written that difficult, there were no columns to be inserted (the most difficult part), so there was even no 2nd loop needed.
I 'll give it another try with lots of explanation at the right side, delete all unnecessary stuff, etc

oh ok. i probably misunderstood then and thats why i keep getting the error. here are screen shots.

change C triggers the event procedure...

which starts the new macro

which starts loop 1

then error...

debug shows this highlighted in the code

maybe i typed something wrong in the code? last thing you said to change was sh6.Range("A" & Rows.Count) .End(xlUp) .Offset(1) .Resize(2, imax) .Value = arr1