I wish to Transfer a row from one Excel Sheet to another using two criteria

RMadden

New Member
Joined
May 30, 2022
Messages
15
Office Version
  1. 2021
Platform
  1. Windows
I have an excel spreadsheet (Excel 2016) with a number of sheets (Local Suburbs). Sheet1 (called "DataInput") collects data from outside the sheet and laying it in a row (basically I copy from another source and drop it there). Now column B has a heading "Unique Number" at B1 with the data starting in Row 2 - This number is as headed different for each row of data.
Also there is a column headed up "Hub location". This is column "H".
My problem is I wish to add any row of data that is added into the "DataInput" sheet across to sheet2 (Kariong) based on the following criteria: -
* Add to the next row after that one that has data in it;
* Only do so if that row of data is not already there; and
* Only transfer rows that relate to the suburb "Kariong" as shown in column H.

I have been able to get the first two done via Command Button with the following code but not to sort out any rows that doesn't relate to "Kariong". I will replicate this button for other suburbs on their individual sheets unless there is an easier way (total suburbs would be ten). I thought if I could get one right the reat can be adapted easy enough.

VBA Code:
Private Sub CommandButton3_Click()

    Dim ws2 As Worksheet, ws1 As Worksheet
    Dim cell As Range, Found As Range
    Dim FirstFound As String
    Dim bCopyInv   As Boolean
    Dim counter    As Long
   
    Set ws2 = Sheets("Kariong")
    Set ws1 = Sheets("DataInput")
   
    For Each cell In ws1.Range("b1", ws1.Range("b" & Rows.Count).End(xlUp))
        bCopyInv = True
        Set Found = ws2.Columns("b").Find(What:=cell.Value, _
                                          LookIn:=xlValues, _
                                          LookAt:=xlWhole, _
                                          SearchOrder:=xlByRows, _
                                          SearchDirection:=xlNext, _
                                          MatchCase:=False)
        If Not Found Is Nothing Then
            FirstFound = Found.Address
            Do
                If Found.Offset(0, 2).Value = cell.Offset(0, 2).Value Then
                    bCopyInv = False
                    Exit Do
                End If
                Set Found = ws2.Columns("b").FindNext(after:=Found)
            Loop Until Found.Address = FirstFound
        End If
       
        If bCopyInv Then
            cell.EntireRow.Copy Destination:=ws2.Range("A" & Rows.Count).End(xlUp).Offset(1)
            counter = counter + 1
        End If
       
    Next cell
   
    MsgBox counter & " orders copied.", vbInformation, "Orders Copy Complete"
End Sub

I must admit I adapted this code from another example and whilst it works I am not sure about the "found.offset" portion as the original code had different criteria it was searching for
Any help you can give will be most appreciated. Thanking you in advance
 
Last edited by a moderator:

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Hi and welcome to MrExcel !

These lines:
Set Found = ws2.Columns("b").Find(What:=cell.Value ...
If Not Found Is Nothing Then
If Found.Offset(0, 2).Value = cell.Offset(0, 2).Value Then
bCopyInv = False
Means, if the value of B of the sheet "DataInput" exists in the column B of the sheet "Kariong" then compares the data of column D of the sheet "Kariong" against the sheet "DataInput", if they are equal then do not copy.
----
I don't understand why you have a Do Loop cycle, which searches for value several times. If you comment that the numbers are unique, then it is enough to look for them only once.
-----
I will replicate this button for other suburbs on their individual sheets unless there is an easier way (total suburbs would be ten)

I help you with the code for all the sheets. You could explain with examples, what data you have in the "DataInput" sheet, which criteria to apply and in which or which sheets to paste.
To give examples use the XL2BB tool minisheet (see my signature). If you have sensitive data, change it to generic data.
 
Upvote 0
"Thanks Dante, the data coming in is as attached image. "Submission on Date" heading is cell A1 and "Hub Location" is H1.
This is Sheet 1 ( named "DataInput") and behind this we have a second sheet Sheet 2, named "Kariong".
The data coming is basically a stock order via a JotForm for a number of different locations, Kariong being one. I would like to keep a list of all orders coming for that location. I can do a temp one via filter but wish to have data remain on the second sheet.

Regards
Robert
 

Attachments

  • Untitled.png
    Untitled.png
    11.9 KB · Views: 12
Upvote 0
Dummy.xlsm
ABCDEFGHIJKLMNOPQRSTUV
1Submission DateUnique NumberDateFirst NameLast NameEmailMob No:Hub LocationTo Be Auto FilledBrushcutter - FS560 >> Mulching Blade[4000 713 3902] >> Standard Holding QtyBrushcutter - FS560 >> Mulching Blade[4000 713 3902] >> On handBrushcutter - FS560 >> Mulching Blade[4000 713 3902] >> Order PlacedBrushcutter - FS560 >> Mulching Blade[4000 713 3902] >> Office Use OnlyBrushcutter - FS560 >> Tri Blade[4000 713 4100] >> Standard Holding QtyBrushcutter - FS560 >> Tri Blade[4000 713 4100] >> On handBrushcutter - FS560 >> Tri Blade[4000 713 4100] >> Order PlacedBrushcutter - FS560 >> Tri Blade[4000 713 4100] >> Office Use OnlyBrushcutter - FS560 >> Saw Blade 225mm FS560/FS460[4000 713 4211] >> Standard Holding QtyBrushcutter - FS560 >> Saw Blade 225mm FS560/FS460[4000 713 4211] >> On handBrushcutter - FS560 >> Saw Blade 225mm FS560/FS460[4000 713 4211] >> Order PlacedBrushcutter - FS560 >> Saw Blade 225mm FS560/FS460[4000 713 4211] >> Office Use OnlyBrushcutter - FS560 >> Duro Cut Line - FS460/FS560[0000 930 3503] >> Standard Holding Qty
22022/06/01 10:39:17StoresOrder-000018May 31, 2022RobertDunloprobert.madden@juparo.com.au0417291641Wyong2204406608
32022/06/01 11:12:42StoresOrder-000019May 29, 2022JillUpthehillrobert.madden@juparo.com.au0417291641Maitland2204406608
42022/06/01 11:29:20StoresOrder-000020May 30, 2022GregTruslerrobert.madden@juparo.com.au0417291641Wyong2204406248
52022/06/01 12:16:54StoresOrder-000021May 30, 2022BillDuncanrobert.madden@juparo.com.au0417291641Wyong2204406608
62022/06/01 12:16:54StoresOrder-000021May 30, 2022JohnThomorobert.madden@juparo.com.au0417291641Wyong2204406608
7
8
Kariong
 
Upvote 0
I have nine sheets,
DataInput, Kariong, Wyong, Cameron Park, Maitland, Singleton Taree Wauchope and Macksville.
In regards to your "DoLoop" comment yep not meant to be there - I copied this code from elsewhere and then couldn't adapt it. When I tied to remove what I considered excess code.
It actually does transfer data from DataInput sheet to Kariong Sheet but doen't distinguish between Kariong or other suburbs. It also copies all the rows each timei press the command button.
BTW the data rows in the mini sheet is dummy and not meaningful only test data.
As you must be aware I am a true beginner with VBA so I thank you for taking your time with me.
 
Upvote 0
It actually does transfer data from DataInput sheet to Kariong Sheet but doen't distinguish between Kariong or other suburbs. It also copies all the rows each timei press the command button.

How to distinguish the data of each suburb.
Create your example again, mark in yellow which records should be copied to sheet "Kariong".
Paste here the minisheet of the sheet "DataInput"

Forget the VBA code for a moment and let's concentrate on the data you have in the "DataInput" sheet, the criteria you want to apply to copy or not copy the records to the "Kariong" sheet.

In your example of the sheet "Kariong" you put a duplicate number, so they are not unique?
1654084110300.png


----
I suggest that you prepare a good example with your sheets "datainput" and "Kariong", then you go back and paste here the two minisheets.
 
Upvote 0
Dummy2.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAMANAOAPAQARASATAUAVAWAXAYAZBABBBCBD
1Submission DateUnique NumberDateFirst NameLast NameEmailMob No:Hub LocationTo Be Auto FilledBrushcutter - FS560 >> Mulching Blade[4000 713 3902] >> Standard Holding QtyBrushcutter - FS560 >> Mulching Blade[4000 713 3902] >> On handBrushcutter - FS560 >> Mulching Blade[4000 713 3902] >> Order PlacedBrushcutter - FS560 >> Mulching Blade[4000 713 3902] >> Office Use OnlyBrushcutter - FS560 >> Tri Blade[4000 713 4100] >> Standard Holding QtyBrushcutter - FS560 >> Tri Blade[4000 713 4100] >> On handBrushcutter - FS560 >> Tri Blade[4000 713 4100] >> Order PlacedBrushcutter - FS560 >> Tri Blade[4000 713 4100] >> Office Use OnlyBrushcutter - FS560 >> Saw Blade 225mm FS560/FS460[4000 713 4211] >> Standard Holding QtyBrushcutter - FS560 >> Saw Blade 225mm FS560/FS460[4000 713 4211] >> On handBrushcutter - FS560 >> Saw Blade 225mm FS560/FS460[4000 713 4211] >> Order PlacedBrushcutter - FS560 >> Saw Blade 225mm FS560/FS460[4000 713 4211] >> Office Use OnlyBrushcutter - FS560 >> Duro Cut Line - FS460/FS560[0000 930 3503] >> Standard Holding QtyBrushcutter - FS560 >> Duro Cut Line - FS460/FS560[0000 930 3503] >> On handBrushcutter - FS560 >> Duro Cut Line - FS460/FS560[0000 930 3503] >> Order PlacedBrushcutter - FS560 >> Duro Cut Line - FS460/FS560[0000 930 3503] >> Office Use OnlyBrushcutter - FS560 >> Locking Pin - Gear Head[4130 893 7800] >> Standard Holding QtyBrushcutter - FS560 >> Locking Pin - Gear Head[4130 893 7800] >> On handBrushcutter - FS560 >> Locking Pin - Gear Head[4130 893 7800] >> Order PlacedBrushcutter - FS560 >> Locking Pin - Gear Head[4130 893 7800] >> Office Use OnlyBrushcutter - FS560 >> Air Filter - FS560[4148 141 0300] >> Standard Holding QtyBrushcutter - FS560 >> Air Filter - FS560[4148 141 0300] >> On handBrushcutter - FS560 >> Air Filter - FS560[4148 141 0300] >> Order PlacedBrushcutter - FS560 >> Air Filter - FS560[4148 141 0300] >> Office Use OnlyBrushcutter - FS560 >> Gear Head FS560[4148 640 0107] >> Standard Holding QtyBrushcutter - FS560 >> Gear Head FS560[4148 640 0107] >> On handBrushcutter - FS560 >> Gear Head FS560[4148 640 0107] >> Order PlacedBrushcutter - FS560 >> Gear Head FS560[4148 640 0107] >> Office Use OnlyBrushcutter - FS560 >> Spark Arrestor FS560[4148 140 6900] >> Standard Holding QtyBrushcutter - FS560 >> Spark Arrestor FS560[4148 140 6900] >> On handBrushcutter - FS560 >> Spark Arrestor FS560[4148 140 6900] >> Order PlacedBrushcutter - FS560 >> Spark Arrestor FS560[4148 140 6900] >> Office Use OnlyBrushcutter - FS560 >> Flange (Collar) nut - Nyloc [4116 642 7601] >> Standard Holding QtyBrushcutter - FS560 >> Flange (Collar) nut - Nyloc [4116 642 7601] >> On handBrushcutter - FS560 >> Flange (Collar) nut - Nyloc [4116 642 7601] >> Order PlacedBrushcutter - FS560 >> Flange (Collar) nut - Nyloc [4116 642 7601] >> Office Use OnlyBrushcutter - FS560 >> Rider Cup - Saw Blade [4116 713 3100] >> Standard Holding QtyBrushcutter - FS560 >> Rider Cup - Saw Blade [4116 713 3100] >> On handBrushcutter - FS560 >> Rider Cup - Saw Blade [4116 713 3100] >> Order PlacedBrushcutter - FS560 >> Rider Cup - Saw Blade [4116 713 3100] >> Office Use OnlyBrushcutter - FS560 >> Guard Washer [ ] >> Standard Holding QtyBrushcutter - FS560 >> Guard Washer [ ] >> On handBrushcutter - FS560 >> Guard Washer [ ] >> Order PlacedBrushcutter - FS560 >> Guard Washer [ ] >> Office Use OnlyBrushcutter - FS560 >> Thrust Plate 60mm - Line Head[4116 710 3800] >> Standard Holding QtyBrushcutter - FS560 >> Thrust Plate 60mm - Line Head[4116 710 3800] >> On handBrushcutter - FS560 >> Thrust Plate 60mm - Line Head[4116 710 3800] >> Order Placed
2
32022/06/02 16:48:39StoresOrder-000027May 19, 2022TommyRandorobert@abc.com0417291641Cameron Park11022033044055066077088099010100111101212
42022/06/02 16:46:45StoresOrder-000026May 10, 2022BillyConnellyrobert@abc.com0417291641Wyong220440660880101001212014140161601818020200222202424
52022/06/02 16:45:34StoresOrder-000025May 30, 2022JohnSmithrobert@abc.com0417291641Kariong11022033044055066077088099010100111101212
62022/06/02 12:38:18StoresOrder-000024Jun 1, 2022RobertDunloprobert@abc.com0417291641Taree110211312413101961571681791810191111012111
72022/06/02 10:54:47StoresOrder-000023Jun 8, 2022RobertMaddenrobert@abc.com0417291641Wyong2024046068081001012012140141601618018200202202224024
82022/06/02 07:43:38StoresOrder-000022Jun 2, 2022RobertMaddenrobert@abc.com0417291641Macksville110220330440550660770880990101001111012120
DataInput



Dummy2.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAMANAOAPAQARASATAUAVAWAXAYAZBABBBCBD
1Submission DateUnique NumberDateFirst NameLast NameEmailMob No:Hub LocationTo Be Auto FilledBrushcutter - FS560 >> Mulching Blade[4000 713 3902] >> Standard Holding QtyBrushcutter - FS560 >> Mulching Blade[4000 713 3902] >> On handBrushcutter - FS560 >> Mulching Blade[4000 713 3902] >> Order PlacedBrushcutter - FS560 >> Mulching Blade[4000 713 3902] >> Office Use OnlyBrushcutter - FS560 >> Tri Blade[4000 713 4100] >> Standard Holding QtyBrushcutter - FS560 >> Tri Blade[4000 713 4100] >> On handBrushcutter - FS560 >> Tri Blade[4000 713 4100] >> Order PlacedBrushcutter - FS560 >> Tri Blade[4000 713 4100] >> Office Use OnlyBrushcutter - FS560 >> Saw Blade 225mm FS560/FS460[4000 713 4211] >> Standard Holding QtyBrushcutter - FS560 >> Saw Blade 225mm FS560/FS460[4000 713 4211] >> On handBrushcutter - FS560 >> Saw Blade 225mm FS560/FS460[4000 713 4211] >> Order PlacedBrushcutter - FS560 >> Saw Blade 225mm FS560/FS460[4000 713 4211] >> Office Use OnlyBrushcutter - FS560 >> Duro Cut Line - FS460/FS560[0000 930 3503] >> Standard Holding QtyBrushcutter - FS560 >> Duro Cut Line - FS460/FS560[0000 930 3503] >> On handBrushcutter - FS560 >> Duro Cut Line - FS460/FS560[0000 930 3503] >> Order PlacedBrushcutter - FS560 >> Duro Cut Line - FS460/FS560[0000 930 3503] >> Office Use OnlyBrushcutter - FS560 >> Locking Pin - Gear Head[4130 893 7800] >> Standard Holding QtyBrushcutter - FS560 >> Locking Pin - Gear Head[4130 893 7800] >> On handBrushcutter - FS560 >> Locking Pin - Gear Head[4130 893 7800] >> Order PlacedBrushcutter - FS560 >> Locking Pin - Gear Head[4130 893 7800] >> Office Use OnlyBrushcutter - FS560 >> Air Filter - FS560[4148 141 0300] >> Standard Holding QtyBrushcutter - FS560 >> Air Filter - FS560[4148 141 0300] >> On handBrushcutter - FS560 >> Air Filter - FS560[4148 141 0300] >> Order PlacedBrushcutter - FS560 >> Air Filter - FS560[4148 141 0300] >> Office Use OnlyBrushcutter - FS560 >> Gear Head FS560[4148 640 0107] >> Standard Holding QtyBrushcutter - FS560 >> Gear Head FS560[4148 640 0107] >> On handBrushcutter - FS560 >> Gear Head FS560[4148 640 0107] >> Order PlacedBrushcutter - FS560 >> Gear Head FS560[4148 640 0107] >> Office Use OnlyBrushcutter - FS560 >> Spark Arrestor FS560[4148 140 6900] >> Standard Holding QtyBrushcutter - FS560 >> Spark Arrestor FS560[4148 140 6900] >> On handBrushcutter - FS560 >> Spark Arrestor FS560[4148 140 6900] >> Order PlacedBrushcutter - FS560 >> Spark Arrestor FS560[4148 140 6900] >> Office Use OnlyBrushcutter - FS560 >> Flange (Collar) nut - Nyloc [4116 642 7601] >> Standard Holding QtyBrushcutter - FS560 >> Flange (Collar) nut - Nyloc [4116 642 7601] >> On handBrushcutter - FS560 >> Flange (Collar) nut - Nyloc [4116 642 7601] >> Order PlacedBrushcutter - FS560 >> Flange (Collar) nut - Nyloc [4116 642 7601] >> Office Use OnlyBrushcutter - FS560 >> Rider Cup - Saw Blade [4116 713 3100] >> Standard Holding QtyBrushcutter - FS560 >> Rider Cup - Saw Blade [4116 713 3100] >> On handBrushcutter - FS560 >> Rider Cup - Saw Blade [4116 713 3100] >> Order PlacedBrushcutter - FS560 >> Rider Cup - Saw Blade [4116 713 3100] >> Office Use OnlyBrushcutter - FS560 >> Guard Washer [ ] >> Standard Holding QtyBrushcutter - FS560 >> Guard Washer [ ] >> On handBrushcutter - FS560 >> Guard Washer [ ] >> Order PlacedBrushcutter - FS560 >> Guard Washer [ ] >> Office Use OnlyBrushcutter - FS560 >> Thrust Plate 60mm - Line Head[4116 710 3800] >> Standard Holding QtyBrushcutter - FS560 >> Thrust Plate 60mm - Line Head[4116 710 3800] >> On handBrushcutter - FS560 >> Thrust Plate 60mm - Line Head[4116 710 3800] >> Order Placed
2
3
Kariong


Hopefully I have provided enough data this time - sorry to waste your time last night.

* Yes unique numbers will be unique - the row you mentioned was just me copying rows to test.

* There are in fact columns "A" to "ZS" in the row to be copied over - so pretty lengthy.

* The process will be a JotForm will come from the "Hub" (aka Suburb - column H). The jotForm's data will be copied and into the next row available in the DataInput Sheet - this will be a manual operation for now.

* All the cells in the row that relate to that Hub will then be copied from the DataInput Sheet to a sheet named after the Hub concerned in our case "Kariong". This will be done by the code we are working on here.

* I have provided both sheets for your perusal but basically the Kariong Sheets is a mirror image of the DataInput sheet - only the data will be restricted to what that location has provided.

* The majority of the columns after the hub location "H" are numerical fields although we have some text fields at the end whereby the user can make comments - however only before the data comes to us.
* The way I see it the Command Button will ask: -

* Are there any rows in DataInput Sheet that have a value in column "H" relating to "Kariong", that is NOT already present in the Kariong Sheet, if yes then copy the whole row to Kariong sheet and place in the next available row. Do not copy and paste any rows that are already present in the Kariong Sheet or have any other suburb named in column "H"

Hopefully this makes it clearer for you

Rgds Robert
 
Upvote 0
Try the following macro. If the data in column "H" does not exist the sheet, then it simply does not copy the record. The macro works for all sheets in your file. Check that you have all your sheets created to store the records of the DataInput sheet.

VBA Code:
Sub TransferRows()
  Dim sh1 As Worksheet, sh As Worksheet
  Dim dic As Object
  Dim a As Variant, b() As Variant, c() As Variant, ky As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
  
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
  Set sh1 = Sheets("DataInput")
  lr = sh1.Range("H" & Rows.Count).End(3).Row
  lc = sh1.Cells(1, Columns.Count).End(1).Column
  a = sh1.Range("A3", sh1.Cells(lr, lc)).Value
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
  
  For Each sh In Sheets
    If sh.Name <> sh1.Name Then
      Erase b
      dic.RemoveAll
      k = 0
      lr = sh.Range("H" & Rows.Count).End(3).Row
      
      If lr > 1 Then
        b = sh.Range("A2:H" & lr).Value
        For i = 1 To UBound(b, 1)
          ky = sh.Name & "|" & b(i, 2)
          dic(ky) = Empty
        Next
      End If
      
      For i = 1 To UBound(a, 1)
        If LCase(a(i, 8)) = LCase(sh.Name) Then
          ky = a(i, 8) & "|" & a(i, 2)
          If Not dic.exists(ky) Then
            k = k + 1
            For j = 1 To UBound(a, 2)
              c(k, j) = a(i, j)
            Next
          End If
        End If
      Next
      
      If k > 0 Then sh.Range("A" & lr + 1).Resize(k, UBound(c, 2)).Value = c
        
    End If
  Next
End Sub
 
Upvote 0
Solution
You beauty works a treat, thank you. You cannot believe how this has made my day.
 
Upvote 0

Forum statistics

Threads
1,223,894
Messages
6,175,252
Members
452,623
Latest member
Techenthusiast

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