How to make it so that entire rows would not be deleted

[studentlearner]

As I am combining data it seems to do the job just that it deletes or removes the entire rows, which I still require.

For context, there are data from columns A to O, and I segregate only the data I require starting from cell Q2, the function I require help with is currently removing the entire rows.

'Start of combining only group members data using a function into a single Group ID

Dim wks As Worksheet

'use as a boolean test to determine when to stop the process
blnDone = False
Set wks = Application.ActiveSheet
wks.Range("Q2").Select
intSct = 0 'save count
While Not blnDone

strSKU = ActiveCell.Offset(0, 0).Value
strCat = ActiveCell.Offset(0, 1).Value

x = 1
strSKUComp = ActiveCell.Offset(x, 0).Value

If strSKUComp <> strSKU Or strSKU = "Null" Then
ActiveCell.Offset(1, 0).Select
End If
'Concat together
While strSKUComp = strSKU
strCat = strCat & ", " & ActiveCell.Offset(x, 1).Value

x = x + 1
strSKUComp = ActiveCell.Offset(x, 0).Value
Wend
If x > 1 Then
ActiveCell.Offset(0, 1).Value = strCat

' determine rows to delete
xdel = x
For d = 1 To xdel - 1
ActiveCell.Offset(1, 0).EntireRow.Delete
'ActiveCell.EntireRow.Delete
Next
ActiveCell.Offset(1, 0).Select
intSct = intSct + 1
If intSct = 20 Then
Application.ActiveWorkbook.Save
intSct = 0
End If
End If

If IsEmpty(ActiveCell) Then
blnDone = True
End If
Wend
MsgBox "done!"
'End of combing multiple data into a single group ID

so I tried meddling with the xdel code onwards, but it seems to ruin how I want the function to work.
as mentioned I still require the function to work how it is, just that it is messing around with my data by deleting entire rows. any help would be great! thanks!

 

[DanteAmor]

It's hard to know what's wrong with the macro if we don't know what result you want. So forget the macro for a moment.
Explain with data what you have and what you want as a result.
You can upload the data here using the XL2BB tool minisheet. (If you have confidential data, use generic data.)

 

[studentlearner]

First Step is identifying what i want and I can do that by inputting what I'm trying to find here:

From the data in segregate it'll go to another sheet and locate the data and this is the data it will locate:

mergeYuNotWorkingProp.xlsm
	A	B	C	D	E
1	BRAND NAME	PRODUCT NAME	Category	Market code	SKU
2	ABC Products	Container - 12" x 5"	Household	15	655585L10
3	ABC Products	Glue, Extra strong	Construction	10	465235L10
4	ABC Products	Glue, Extra strong	Household	15	465235L10
5	ABC Products	Glue, Extra strong	Misc	16	465235L10
6	ABC Products	Tape, clear	Crafts	10	465385L10
7	ABC Products	Tape, clear	Household	16	465385L10
8	Nimble Thimble, Inc.	Candy dispenser	Commercial	15	C58835200
9	Nimble Thimble, Inc.	Candy dispenser	Misc	16	C58835200
10	Nimble Thimble, Inc.	Coffee Filters	Household	10	L28621000
11	Nimble Thimble, Inc.	Coffee Filters	Misc	14	L28621000
12	Nimble Thimble, Inc.	Throw Blanket	Household	12	D0004652
13	Nimble Thimble, Inc.	Throw Blanket	Misc	13	D0004652
14	Northshore Fun Co	Make your own bobblehead	Household	16	ZC002109
15	Northshore Fun Co	Make your own bobblehead	Misc	17	ZC002109
16	Northshore Fun Co	Phone Charger	Electronics	12	ZC555999
17	Northshore Fun Co	Phone Charger	Utilities	16	ZC555999
18	Our Big Manufacturing	Candy dispenser	Commercial	15	C58835200
19	Our Big Manufacturing	Candy dispenser	Misc	16	C58835200
20	Our Big Manufacturing	Coffee Filters	Household	10	L28621000
21	Our Big Manufacturing	Coffee Filters	Misc	14	L28621000
22	Our Big Manufacturing	Throw Blanket	Household	12	D0004652
23	Our Big Manufacturing	Throw Blanket	Misc	13	D0004652
24	XYZ Household Products	Container - 12" x 5"	Household	15	655585L10
Data

Thirdly, after locating the data it will isolate data to cell F and should look something like this:

mergeYuNotWorkingProp.xlsm
	A	B	C	D	E	F	G	H	I	J
1	BRAND NAME	PRODUCT NAME	Category	Market code	SKU
2	ABC Products	Container - 12" x 5"	Household	15	655585L10	Nimble Thimble, Inc.	Candy dispenser	Commercial	15	C58835200
3	ABC Products	Glue, Extra strong	Construction	10	465235L10	Nimble Thimble, Inc.	Candy dispenser	Misc	16	C58835200
4	ABC Products	Glue, Extra strong	Household	15	465235L10	Nimble Thimble, Inc.	Coffee Filters	Household	10	L28621000
5	ABC Products	Glue, Extra strong	Misc	16	465235L10	Nimble Thimble, Inc.	Coffee Filters	Misc	14	L28621000
6	ABC Products	Tape, clear	Crafts	10	465385L10	Nimble Thimble, Inc.	Throw Blanket	Household	12	D0004652
7	ABC Products	Tape, clear	Household	16	465385L10	Nimble Thimble, Inc.	Throw Blanket	Misc	13	D0004652
8	Nimble Thimble, Inc.	Candy dispenser	Commercial	15	C58835200
9	Nimble Thimble, Inc.	Candy dispenser	Misc	16	C58835200
10	Nimble Thimble, Inc.	Coffee Filters	Household	10	L28621000
11	Nimble Thimble, Inc.	Coffee Filters	Misc	14	L28621000
12	Nimble Thimble, Inc.	Throw Blanket	Household	12	D0004652
13	Nimble Thimble, Inc.	Throw Blanket	Misc	13	D0004652
14	Northshore Fun Co	Make your own bobblehead	Household	16	ZC002109
15	Northshore Fun Co	Make your own bobblehead	Misc	17	ZC002109
16	Northshore Fun Co	Phone Charger	Electronics	12	ZC555999
17	Northshore Fun Co	Phone Charger	Utilities	16	ZC555999
18	Our Big Manufacturing	Candy dispenser	Commercial	15	C58835200
19	Our Big Manufacturing	Candy dispenser	Misc	16	C58835200
20	Our Big Manufacturing	Coffee Filters	Household	10	L28621000
21	Our Big Manufacturing	Coffee Filters	Misc	14	L28621000
22	Our Big Manufacturing	Throw Blanket	Household	12	D0004652
23	Our Big Manufacturing	Throw Blanket	Misc	13	D0004652
24	XYZ Household Products	Container - 12" x 5"	Household	15	655585L10
25	XYZ Household Products	Glue, Extra strong	Construction	10	465235L10
26	XYZ Household Products	Glue, Extra strong	Household	15	465235L10
Data

Now here's where the problem lies, I am trying to merge the data with I believe CONCAT and as it's doing its job it seems delete multiple rows at once, here's how it looks after completion:

mergeYuNotWorkingProp.xlsm
	A	B	C	D	E	F	G	H	I	J
1	BRAND NAME	PRODUCT NAME	Category	Market code	SKU
2	ABC Products	Container - 12" x 5"	Household	15	655585L10	Nimble Thimble, Inc.	Candy dispenser	Commercial,Misc	15,16	C58835200
3	ABC Products	Glue, Extra strong	Household	15	465235L10	Nimble Thimble, Inc.	Coffee Filters	Household,Misc	10,14	L28621000
4	ABC Products	Tape, clear	Crafts	10	465385L10	Nimble Thimble, Inc.	Throw Blanket	Household,Misc	12,13	D0004652
5	Nimble Thimble, Inc.	Candy dispenser	Commercial	15	C58835200
6	Nimble Thimble, Inc.	Candy dispenser	Misc	16	C58835200
7	Nimble Thimble, Inc.	Coffee Filters	Household	10	L28621000
8	Nimble Thimble, Inc.	Coffee Filters	Misc	14	L28621000
9	Nimble Thimble, Inc.	Throw Blanket	Household	12	D0004652
10	Nimble Thimble, Inc.	Throw Blanket	Misc	13	D0004652
11	Northshore Fun Co	Make your own bobblehead	Household	16	ZC002109
12	Northshore Fun Co	Make your own bobblehead	Misc	17	ZC002109
13	Northshore Fun Co	Phone Charger	Electronics	12	ZC555999
14	Northshore Fun Co	Phone Charger	Utilities	16	ZC555999
15	Our Big Manufacturing	Candy dispenser	Commercial	15	C58835200
16	Our Big Manufacturing	Candy dispenser	Misc	16	C58835200
17	Our Big Manufacturing	Coffee Filters	Household	10	L28621000
18	Our Big Manufacturing	Coffee Filters	Misc	14	L28621000
19	Our Big Manufacturing	Throw Blanket	Household	12	D0004652
20	Our Big Manufacturing	Throw Blanket	Misc	13	D0004652
21	XYZ Household Products	Container - 12" x 5"	Household	15	655585L10
22	XYZ Household Products	Glue, Extra strong	Construction	10	465235L10
23	XYZ Household Products	Glue, Extra strong	Household	15	465235L10
Data

And lastly here's the code: that I'm working with
Sub Macro1()
'
' Macro1 Macro
'

'
Range("Table1[Segregarte]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


Dim c As Range
Dim findWhat As String
Dim i As Long

i = 2




With Worksheets(1).Range("A:A")

'find it based on diploma name
Set c = .Find(What:=Range("F2").Value, MatchCase:=False, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address

Do
Cells(i, 6) = c.Value
Cells(i, 7) = c.Offset(, 1).Value
Cells(i, 8) = c.Offset(, 2).Value
Cells(i, 9) = c.Offset(, 3).Value
Cells(i, 10) = c.Offset(, 4).Value
'

Set c = .FindNext(c)
MsgBox "Value found in cell " & c.Address

i = i + 1
Loop While Not c Is Nothing And c.Address <> firstAddress
End If

End With




Dim wks As Worksheet

'use as a boolean test to determine when to stop the process
blnDone = False
Set wks = Application.ActiveSheet
wks.Range("F2").Select
intSct = 0 'save count
While Not blnDone

strSKU = ActiveCell.Offset(0, 4).Value
strCat = ActiveCell.Offset(0, 2).Value
strMktcd = ActiveCell.Offset(0, 3).Value
x = 1
strSKUComp = ActiveCell.Offset(x, 4).Value

If strSKUComp <> strSKU Or strSKU = "Null" Then
ActiveCell.Offset(1, 0).Select
End If

While strSKUComp = strSKU
strCat = strCat & "," & ActiveCell.Offset(x, 2).Value
strMktcd = strMktcd & "," & ActiveCell.Offset(x, 3).Value
x = x + 1
strSKUComp = ActiveCell.Offset(x, 4).Value
Wend
If x > 1 Then
ActiveCell.Offset(0, 2).Value = strCat
ActiveCell.Offset(0, 3).Value = strMktcd

' determine rows to delete
xdel = x
For d = 1 To xdel - 1
ActiveCell.Offset(1, 0).EntireRow.Delete

Next
ActiveCell.Offset(1, 0).Select
intSct = intSct + 1
If intSct = 20 Then
Application.ActiveWorkbook.Save
intSct = 0
End If
End If

If IsEmpty(ActiveCell) Then
blnDone = True
End If

Wend
MsgBox "done!"

'Range("F2").Select
'Range(Selection, Selection.End(xlToRight)).Select
'Range(Selection, Selection.End(xlDown)).Select
'Selection.Cut
'Sheets("Sheet1").Select
'Range("A1").Select
'ActiveSheet.Paste

End Sub

any help would be great thanks!

 

[DanteAmor]

Try this approach:

Sub Macro1_a()
  Dim sh As Worksheet
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim seg As String, ky As String
  Dim i As Long, f As Long
  
  Set sh = Sheets("Data")
  Set dic = CreateObject("Scripting.Dictionary")
  seg = Range("Table1[Segregarte]").Value
  a = sh.Range("A2", sh.Range("E" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To 5)
  
  For i = 1 To UBound(a, 1)
    If a(i, 1) = seg Then
      ky = a(i, 1) & "|" & a(i, 5)
      If Not dic.exists(ky) Then dic(ky) = dic.Count + 1
      f = dic(ky)
      b(f, 1) = a(i, 1)
      b(f, 2) = a(i, 2)
      b(f, 3) = IIf(b(f, 3) = "", a(i, 3), b(f, 3) & "," & a(i, 3))
      b(f, 4) = IIf(b(f, 4) = "", a(i, 4), b(f, 4) & "," & a(i, 4))
      b(f, 5) = a(i, 5)
    End If
  Next
  sh.Range("F2").Resize(dic.Count, 5).Value = b
End Sub

 

[studentlearner]

Wow, ok, this is way more efficient than what I'm working with. Thanks!!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.