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

studentlearner

New Member
Joined
Oct 7, 2021
Messages
30
Office Version
  1. 365
Platform
  1. Windows
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!
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
14,206
Office Version
  1. 2007
Platform
  1. Windows
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

New Member
Joined
Oct 7, 2021
Messages
30
Office Version
  1. 365
Platform
  1. Windows
First Step is identifying what i want and I can do that by inputting what I'm trying to find here:

1635988330539.png


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
ABCDE
1BRAND NAMEPRODUCT NAMECategoryMarket codeSKU
2ABC ProductsContainer - 12" x 5"Household15655585L10
3ABC ProductsGlue, Extra strongConstruction10465235L10
4ABC ProductsGlue, Extra strongHousehold15465235L10
5ABC ProductsGlue, Extra strongMisc16465235L10
6ABC ProductsTape, clearCrafts10465385L10
7ABC ProductsTape, clearHousehold16465385L10
8Nimble Thimble, Inc.Candy dispenserCommercial15C58835200
9Nimble Thimble, Inc.Candy dispenserMisc16C58835200
10Nimble Thimble, Inc.Coffee FiltersHousehold10L28621000
11Nimble Thimble, Inc.Coffee FiltersMisc14L28621000
12Nimble Thimble, Inc.Throw BlanketHousehold12D0004652
13Nimble Thimble, Inc.Throw BlanketMisc13D0004652
14Northshore Fun CoMake your own bobbleheadHousehold16ZC002109
15Northshore Fun CoMake your own bobbleheadMisc17ZC002109
16Northshore Fun CoPhone ChargerElectronics12ZC555999
17Northshore Fun CoPhone ChargerUtilities16ZC555999
18Our Big ManufacturingCandy dispenserCommercial15C58835200
19Our Big ManufacturingCandy dispenserMisc16C58835200
20Our Big ManufacturingCoffee FiltersHousehold10L28621000
21Our Big ManufacturingCoffee FiltersMisc14L28621000
22Our Big ManufacturingThrow BlanketHousehold12D0004652
23Our Big ManufacturingThrow BlanketMisc13D0004652
24XYZ Household ProductsContainer - 12" x 5"Household15655585L10
Data



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

mergeYuNotWorkingProp.xlsm
ABCDEFGHIJ
1BRAND NAMEPRODUCT NAMECategoryMarket codeSKU
2ABC ProductsContainer - 12" x 5"Household15655585L10Nimble Thimble, Inc.Candy dispenserCommercial15C58835200
3ABC ProductsGlue, Extra strongConstruction10465235L10Nimble Thimble, Inc.Candy dispenserMisc16C58835200
4ABC ProductsGlue, Extra strongHousehold15465235L10Nimble Thimble, Inc.Coffee FiltersHousehold10L28621000
5ABC ProductsGlue, Extra strongMisc16465235L10Nimble Thimble, Inc.Coffee FiltersMisc14L28621000
6ABC ProductsTape, clearCrafts10465385L10Nimble Thimble, Inc.Throw BlanketHousehold12D0004652
7ABC ProductsTape, clearHousehold16465385L10Nimble Thimble, Inc.Throw BlanketMisc13D0004652
8Nimble Thimble, Inc.Candy dispenserCommercial15C58835200
9Nimble Thimble, Inc.Candy dispenserMisc16C58835200
10Nimble Thimble, Inc.Coffee FiltersHousehold10L28621000
11Nimble Thimble, Inc.Coffee FiltersMisc14L28621000
12Nimble Thimble, Inc.Throw BlanketHousehold12D0004652
13Nimble Thimble, Inc.Throw BlanketMisc13D0004652
14Northshore Fun CoMake your own bobbleheadHousehold16ZC002109
15Northshore Fun CoMake your own bobbleheadMisc17ZC002109
16Northshore Fun CoPhone ChargerElectronics12ZC555999
17Northshore Fun CoPhone ChargerUtilities16ZC555999
18Our Big ManufacturingCandy dispenserCommercial15C58835200
19Our Big ManufacturingCandy dispenserMisc16C58835200
20Our Big ManufacturingCoffee FiltersHousehold10L28621000
21Our Big ManufacturingCoffee FiltersMisc14L28621000
22Our Big ManufacturingThrow BlanketHousehold12D0004652
23Our Big ManufacturingThrow BlanketMisc13D0004652
24XYZ Household ProductsContainer - 12" x 5"Household15655585L10
25XYZ Household ProductsGlue, Extra strongConstruction10465235L10
26XYZ Household ProductsGlue, Extra strongHousehold15465235L10
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
ABCDEFGHIJ
1BRAND NAMEPRODUCT NAMECategoryMarket codeSKU
2ABC ProductsContainer - 12" x 5"Household15655585L10Nimble Thimble, Inc.Candy dispenserCommercial,Misc15,16C58835200
3ABC ProductsGlue, Extra strongHousehold15465235L10Nimble Thimble, Inc.Coffee FiltersHousehold,Misc10,14L28621000
4ABC ProductsTape, clearCrafts10465385L10Nimble Thimble, Inc.Throw BlanketHousehold,Misc12,13D0004652
5Nimble Thimble, Inc.Candy dispenserCommercial15C58835200
6Nimble Thimble, Inc.Candy dispenserMisc16C58835200
7Nimble Thimble, Inc.Coffee FiltersHousehold10L28621000
8Nimble Thimble, Inc.Coffee FiltersMisc14L28621000
9Nimble Thimble, Inc.Throw BlanketHousehold12D0004652
10Nimble Thimble, Inc.Throw BlanketMisc13D0004652
11Northshore Fun CoMake your own bobbleheadHousehold16ZC002109
12Northshore Fun CoMake your own bobbleheadMisc17ZC002109
13Northshore Fun CoPhone ChargerElectronics12ZC555999
14Northshore Fun CoPhone ChargerUtilities16ZC555999
15Our Big ManufacturingCandy dispenserCommercial15C58835200
16Our Big ManufacturingCandy dispenserMisc16C58835200
17Our Big ManufacturingCoffee FiltersHousehold10L28621000
18Our Big ManufacturingCoffee FiltersMisc14L28621000
19Our Big ManufacturingThrow BlanketHousehold12D0004652
20Our Big ManufacturingThrow BlanketMisc13D0004652
21XYZ Household ProductsContainer - 12" x 5"Household15655585L10
22XYZ Household ProductsGlue, Extra strongConstruction10465235L10
23XYZ Household ProductsGlue, Extra strongHousehold15465235L10
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

Well-known Member
Joined
Dec 3, 2018
Messages
14,206
Office Version
  1. 2007
Platform
  1. Windows
Try this approach:

VBA Code:
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
 
Solution

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
14,206
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,574
Messages
5,770,928
Members
425,652
Latest member
Pemby

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
Top