VBA to Transfer Range of Cells with Merge & Grouping - vba

Question

Not sure how to put this in words, but basically macro is run from the sheet1 of WorkBook1, and it should produce one like sheet1 of WorkBook2. (WB2 Sheet1 is empty)
The trick is that macro should only work with user selected range.
So if A1:A7 is selected, it will only grab data from A1:A7 to last column with data
If nothing is selected then exit sub with msgbox or something
Order/sort does not matter as long as it merges XYs duplicates and group respective fruits together.
A B => A B C
1 XY3 Apple => 1 H XY1
2 XY1 Orange => 2 D Orange
3 XY3 Banana => 3 H XY2
4 XY3 Banana => 4 D Orange
5 XY3 Peach => 5 H XY3
6 XY4 Orange => 6 D Apple
7 XY2 Orange => 7 D Banana
8 XY7 Apple => 8 D Banana
=> 9 D Peach
=> 10 H XY4
=> 11 D Orange
[WB1 Sheet1] => [WB2 Sheet1]
This might be difficult but I am desperately seeking for help.
Thank you so much!

Answer 1

I set up this macro to copy to sheet2 of the same workbook. To save to a new workbook just update the following line of code with your workbook name instead of activeworkbook.
Set sheetB = ActiveWorkbook.Sheets("Sheet2")
Started with the following data in sheet 1 and a blank sheet 2:
Select A1 to A8 and run this macro:
Sub CopyAndFormat()
If IsEmpty(Selection) Then
MsgBox ("Empty Cell")
Exit Sub
End If
Dim sheet As Worksheet
Set sheetA = ActiveWorkbook.Sheets("Sheet1")
Set sheetB = ActiveWorkbook.Sheets("Sheet2")
Dim FirstRow As Long, LastRow As Long
FirstRow = Selection.Rows(1).Row
LastRow = Selection.Rows.Count + FirstRow - 1
'First Column
Dim rngA As Range
Set rngA = Range("A" & FirstRow & ":A" & LastRow)
Dim datA As Variant
datA = rngA
Dim i As Long
'Second Column Match
Dim rngB As Range
Set rngB = Range("B" & FirstRow & ":B" & LastRow)
Dim datB As Variant
datB = rngB
Dim j As Long
Dim resultA As Variant
Dim resultB As Variant
Dim rng As Range
Dim rngr As Range
Set rng = sheetB.Range("A1:A" & LastRow + 100)
Set rngr = sheetB.Range("B1:B" & LastRow + 100)
resultA = rng
resultB = rngr
'Store duplicates
Dim rngString As String
rngString = "empty"
Dim match As Boolean
match = False
Dim cntr As Integer
cntr = 1
'First Column loop
For i = LBound(datA, 1) To UBound(datA, 1)
If rngString <> "empty" Then
If Not Intersect(Range("A" & i), Range(rngString)) Is Nothing Then
GoTo nextloop
End If
End If
'Second Column Loop
For j = LBound(datA, 1) + i To UBound(datA, 1)
If i <> j And datA(i, 1) = datA(j, 1) And Not IsEmpty(datA(j, 1)) And Not IsEmpty(datA(i, 1)) Then
'copy position of duplicate in variant
If rngString = "empty" Then
match = True
resultA(cntr, 1) = datA(i, 1)
resultB(cntr + 1, 1) = datB(i, 1)
resultB(cntr + 1, 1) = datB(i, 1)
resultB(cntr + 2, 1) = datB(j, 1)
rngString = "A" & i & ",A" & j
cntr = cntr + 2
Else
resultB(cntr + 1, 1) = datB(j, 1)
cntr = cntr + 1
rngString = rngString & "," & "A" & j
End If
End If
Next
If match = False Then
resultA(cntr + 1, 1) = datA(i, 1)
resultB(cntr + 2, 1) = datB(i, 1)
cntr = cntr + 2
End If
match = False
'cntr = cntr + 1
nextloop:
Next
rng = resultA
rngr = resultB
End Sub
You'll get the following on sheet2:
Sorry the code is a little messy and I hate using goto's but this will get you started.