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
 
Sort by date Sort by votes
is it with my file in #17 or with an adapted file of yours ?
 
Upvote 0

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
BSALV said:
is it with my file in #17 or with an adapted file of yours ?
Click to expand...
im still using yours from #17. i didnt change anything except toggle between true/false for the bquick per the comment. same error mismatch for both.
 
Upvote 0
was the row you tried to archive not within a contiguous block around cell A1, what i try to say, is there between the row you want to archive and row 1 at least 1 empty row ?
see below, you try to archive a row >=12 with such an empty row in 11 ?
ratling (1).xlsm
ABCDEFGHIJK
1Employee nameDepartment assignedEmployee statusProductivity Rate/Hour/DepartmentTotal Lab RVU per Hour 7/3/2021Total Lab RVU per Hour 6/26/2021Total Lab RVU per Hour 6/19/2022Total Lab RVU per Hour 6/12/2022Total Lab RVU per Hour 6/19/2021Total Lab RVU per Hour 6/12/2021Total Lab RVU per Hour 6/5/2021
2Eric1HistologyTransferred244441sssssfffff39-29
3Eric2HistologyTransferred244441sssssfffff40-30
4Eric3HistologyTransferred244441sssssfffff41-31
5Eric6HistologyTransferred244441sssssfffff44-34
6Eric7HistologyTransferred244441sssssfffff45-35
7Eric16HistologyTransferred244441sssssfffff55-45
8Eric17HistologyTransferred244441sssssfffff56-46
9Eric18HistologyTransferred244441sssssfffff57-47
10Eric21HistologyTransferred244441sssssfffff60-50
11
12Eric21HistologyTransferred244441sssssfffff60-50
13Eric6HistologyTransferred244441sssssfffff44-34
14Eric7HistologyTransferred244441sssssfffff45-35
15Eric16HistologyTransferred244441sssssfffff55-45
Summary


Rattling.xlsm

instead of currentregion now usedrange
arr = sh2.UsedRange.Resize(, UBound(a, 2)).Value 'read data into an array


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.UsedRange.Resize(, UBound(a, 2)).Value                      '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
 
Last edited:
Upvote 0
BSALV said:
was the row you tried to archive not within a contiguous block around cell A1, what i try to say, is there between the row you want to archive and row 1 at least 1 empty row ?
see below, you try to archive a row >=12 with such an empty row in 11 ?
ratling (1).xlsm
ABCDEFGHIJK
1Employee nameDepartment assignedEmployee statusProductivity Rate/Hour/DepartmentTotal Lab RVU per Hour 7/3/2021Total Lab RVU per Hour 6/26/2021Total Lab RVU per Hour 6/19/2022Total Lab RVU per Hour 6/12/2022Total Lab RVU per Hour 6/19/2021Total Lab RVU per Hour 6/12/2021Total Lab RVU per Hour 6/5/2021
2Eric1HistologyTransferred244441sssssfffff39-29
3Eric2HistologyTransferred244441sssssfffff40-30
4Eric3HistologyTransferred244441sssssfffff41-31
5Eric6HistologyTransferred244441sssssfffff44-34
6Eric7HistologyTransferred244441sssssfffff45-35
7Eric16HistologyTransferred244441sssssfffff55-45
8Eric17HistologyTransferred244441sssssfffff56-46
9Eric18HistologyTransferred244441sssssfffff57-47
10Eric21HistologyTransferred244441sssssfffff60-50
11
12Eric21HistologyTransferred244441sssssfffff60-50
13Eric6HistologyTransferred244441sssssfffff44-34
14Eric7HistologyTransferred244441sssssfffff45-35
15Eric16HistologyTransferred244441sssssfffff55-45
Summary


Rattling.xlsm

instead of currentregion now usedrange
arr = sh2.UsedRange.Resize(, UBound(a, 2)).Value 'read data into an array


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.UsedRange.Resize(, UBound(a, 2)).Value                      '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...
I will try as soon as I am able to. There are no blank or skipped rows. At the moment row 1 has the headers and 2-97 has the data. Last row will change periodically depending on staff levels. I dont think we would ever have more that 150 rows at any given time on the summary tab but it would be fluid.
 
Upvote 0
in the morning, with a clear view ..., 1 line to prevent that error
Rich (BB code): 
                  k1 = "new"                                  'k1 is not numeric, an error, so make it a string instead to avoid that error
Rattling.xlsm
 
Upvote 0
BSALV said:
in the morning, with a clear view ..., 1 line to prevent that error
Rich (BB code): 
                  k1 = "new"                                  'k1 is not numeric, an error, so make it a string instead to avoid that error
Rattling.xlsm
Click to expand...
i cannot open that file, says i dont have permissions, it may just be my IT restrictions at work.
 
Upvote 0
the VBA code for the macro in a normal module, the other one isn't changed.
It's the same as in the link.
It has to do something with your IT-restrictions, because i had no problems with the link.
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"

          On Error GoTo fout
          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
                    k1 = "new"                                  'k1 is not numeric, an error, so make it a string instead to avoid that error
               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
          On Error GoTo 0
          GoTo okay
fout:
          MsgBox "k is " & k: End

okay:
          If Not bquick Then
               MsgBox "columns " & sh2.Name & vbLf & "name and columnnumber" & vbLf & vbLf & Join(Application.Index(a, 3, 0), vbLf) & IIf(btest, vbLf & vbLf & "because of new added column(s), a 2nd run", "")
               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.UsedRange.Resize(, UBound(a, 2)).Value           '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:
the VBA code for the macro in a normal module, the other one isn't changed.
It's the same as in the link.
It has to do something with your IT-restrictions, because i had no problems with the link.
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"

          On Error GoTo fout
          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
                    k1 = "new"                                  'k1 is not numeric, an error, so make it a string instead to avoid that error
               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
          On Error GoTo 0
          GoTo okay
fout:
          MsgBox "k is " & k: End

okay:
          If Not bquick Then
               MsgBox "columns " & sh2.Name & vbLf & "name and columnnumber" & vbLf & vbLf & Join(Application.Index(a, 3, 0), vbLf) & IIf(btest, vbLf & vbLf & "because of new added column(s), a 2nd run", "")
               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.UsedRange.Resize(, UBound(a, 2)).Value           '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...
did you see my email?
 
Upvote 0
BSALV said:
the VBA code for the macro in a normal module, the other one isn't changed.
It's the same as in the link.
It has to do something with your IT-restrictions, because i had no problems with the link.
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"

          On Error GoTo fout
          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
                    k1 = "new"                                  'k1 is not numeric, an error, so make it a string instead to avoid that error
               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
          On Error GoTo 0
          GoTo okay
fout:
          MsgBox "k is " & k: End

okay:
          If Not bquick Then
               MsgBox "columns " & sh2.Name & vbLf & "name and columnnumber" & vbLf & vbLf & Join(Application.Index(a, 3, 0), vbLf) & IIf(btest, vbLf & vbLf & "because of new added column(s), a 2nd run", "")
               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.UsedRange.Resize(, UBound(a, 2)).Value           '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...
when i put this code into the live data it seems to go ok but still received the "impossible, ptr can never be >=3" msgbx
 
Upvote 0
BSALV said:
the VBA code for the macro in a normal module, the other one isn't changed.
It's the same as in the link.
It has to do something with your IT-restrictions, because i had no problems with the link.
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"

          On Error GoTo fout
          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
                    k1 = "new"                                  'k1 is not numeric, an error, so make it a string instead to avoid that error
               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
          On Error GoTo 0
          GoTo okay
fout:
          MsgBox "k is " & k: End

okay:
          If Not bquick Then
               MsgBox "columns " & sh2.Name & vbLf & "name and columnnumber" & vbLf & vbLf & Join(Application.Index(a, 3, 0), vbLf) & IIf(btest, vbLf & vbLf & "because of new added column(s), a 2nd run", "")
               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.UsedRange.Resize(, UBound(a, 2)).Value           '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...
 
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
466
ItsNursinTime
I
M
  • Solved
Copy and paste multiple matching rows to a new sheet
Replies
6
Views
73
Multim
M
A
  • Question
Insert new column(DATE) up to finish month and move to next sheet
Replies
0
Views
122
Amer Omar
A
T
  • Question
Sort Sheet By Date
2
Replies
11
Views
240
Alex Blakenburg
A
W
  • Question
SCHEDULE DASHBOARD VBA CODE (AUTOMATCICALLY TOGGLE TO MATCHING COLUMN)
Replies
0
Views
81
Willkim
W

Forum statistics

Threads
1,214,919
Messages
6,122,260
Members
449,075
Latest member
staticfluids

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