Data sort & transfer to different sheet

[kesh321]

Hello,

I am trying to figure out this problem.

Basically I have 2 sheets with identical purpose - to reflect the stock.

The old sheet was messy and not sorted, no constant locations, duplicate locations, however I know that newer entries were added to the bottom.

So each location has 3 slots, like it is supposed to be, in the new sheet.
There are cases where, in the old sheet, you have 1 entry per location, no entries at all, or more than 3 entries.

What I need to achieve:

-Find last matching row in old sheet, compared to new sheet, column A.
-Copy over the last matching row from old data, to first matching row in the new sheet.
-Repeat until no more matches found.

What I've got so far:

Sub transfer()

Dim sh1 As Worksheet, sh2 As Worksheet, rng1 As Range, rng2 As Range


Set sh1 = Sheets("Main")
Set sh2 = Sheets("Data")


    For Each rng1 In sh2.Range("A2", sh2.Cells(Rows.Count, 2).End(xlUp))
        Set rng2 = sh1.Range("A2:A10").Find(rng1.Value, , xlValues, xlWhole)
            If Not rng2 Is Nothing Then
                rng2.Offset(, 1) = rng1.Offset(, 1).Value
            End If
            Next
End Sub

It finds the last matching row in old data, but copies over only one match, and not in the first matching row into new sheet.

Example, desired result in column C:

Sheet "Main" (new) - this is where i would need excel to paste my values to

LOCATION	DESCRIPTION	DESIRED
100A		<- Data!B2
100B
100C
101A		<- Data!B7
101B		<- Data!B6
101C		<- Data!B5
102A		<- Data!B10
102B		<- Data!B9
102C

<tbody>
</tbody>

Sheet "Data" (old) - this is where i would need excel to copy my values from

LOCATION	DESCRIPTION	<- cell
100	packing supplies <tbody> </tbody>	b2
101	IT hardware <tbody> </tbody>	b3
101	medical supplies <tbody> </tbody>	b4
101	medical supplies <tbody> </tbody>	b5
101	medical supplies <tbody> </tbody>	b6
101	furniture <tbody> </tbody>	b7
		b8
102	archive <tbody> </tbody>	b9
102	metal bars <tbody> </tbody>	b10

<tbody>
</tbody>

So the end result would look like this:

LOCATION	DESCRIPTION
100A	packing supplies
100B
100C
101A	furniture <tbody> </tbody>
101B	medical supplies
101C	medical supplies
102A	metal bars
102B	archive
102C

<tbody>
</tbody>

Any help appreciated.

Thanks,
Matt.​

 

[Fluff]

Hi & welcome to MrExcel.
You have Cross posted this here https://www.excelforum.com/excel-programming-vba-macros/1234209-data-transfer.html

While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

 

[kesh321]

Hi Fluff,

Sorry about that.

Im not going to receive any help in this matter on excelforum :/
So please consider this problem on-going.

Any help appreciated.

Basically I need a piece of code with a loop until condition is met (no more matches) and a way to get that last match and copy it over to 'Main' as the first value for that specific match (location)

I think I could take things from there, if someone could help with that bit.

Thanks,
Matt.

 

[kesh321]

Here is the link to the original post on excelforum:
https://www.excelforum.com/excel-programming-vba-macros/1234209-data-transfer.html

 

[kesh321]

Bump

 

[kesh321]

bump

 

[Fluff]

How about

Sub transfer()
   Dim sh1 As Worksheet, sh2 As Worksheet
   Dim r As Long, a As Long
   Dim v1 As Variant, v2 As String, b As String
   
   Set sh1 = Sheets("Main")
   Set sh2 = Sheets("Data")
   With CreateObject("Scripting.dictionary")
      For r = sh2.Range("A" & Rows.Count).End(xlUp).row To 2 Step -1
         v1 = sh2.Range("A" & r).Value: v2 = sh2.Range("B" & r).Value
         If Not .exists(v1) Then
            .Add v1, Array(1, v2)
         ElseIf .Item(v1)(0) < 3 Then
            a = .Item(v1)(0) + 1: b = .Item(v1)(1) & "|" & v2
            .Item(v1) = Array(a, b)
         End If
      Next r
      For r = 2 To sh1.Range("A" & Rows.Count).End(xlUp).row Step 3
         a = Left(sh1.Range("A" & r), 3)
         If .exists(a) Then
            v1 = Split(.Item(a)(1), "|")
            If UBound(v1) > 0 Then
               sh1.Range("B" & r).Resize(UBound(v1) + 1).Value = Application.Transpose(Split(.Item(a)(1), "|"))
            Else
               sh1.Range("B" & r).Value = v1
            End If
         End If
      Next r
   End With
End Sub

 

[kesh321]

Hey Fluff,

Thank You that works great.

Appreciated a lot!

Please consider this problem as solved.
I would like to mark this thread as solved, but I can't see an option to do so anywhere.

Thanks,
Matt.

 

[Fluff]

Glad to help & thanks for the feedback.
This site doesn't support marking threads as solved.