Need Help with VBA Code, Not sure if its possible.

[Giovanni03]

Hello Everyone!

I've been thinking of a way to improve a certain function that I currently use on on one my of workbooks. Its a copy a paste code that allows me to copy any amount of rows that i select over into another sheet. What I do now is highlight specific words in Column I then with those highlighted cells I'm able to identify what I need to move over onto another sheet. If you're thinking why don't you just had a set up where those words in column I are identified and copied is because they're only a part of a larger order. That's were I'm stuck...

Is it at all possible if cells are highlighted (or Bold) in Column I then it'll copy paste all of the rows based on the order # (Column D) into a new sheet? As well as delete all of the copied information from the first sheet that it copied it from (avoid duplicate data)

So basically, If cells in column I are highlighted then in column D the order number will be the same.

See below of an example of what I'm talking about,

Column D Column I

Order # 324512	​	Customer Name	SERVICE	9410101​	Product Description
Order # 324512	0:40:00​	Customer Name	SERVICE	5246600​	Product Description
Order # 324512	0:40:00​	Customer Name	DELIVERY	3762114​	Product Description (Highlighted Cell)
Order # 324512	0:40:00​	Customer Name	DELIVERY	5770014​	Product Description
Order # 324512	0:40:00​	Customer Name	DELIVERY	5446387​	Product Description
Order # 324512	0:40:00​	Customer Name	DELIVERY	8930357​	Product Description (Highlighted Cell)
Order # 324512	0:40:00​	Customer Name	DELIVERY	9282812​	Product Description
Order # 324512	0:40:00​	Customer Name	DELIVERY	6451044​	Product Description (Highlighted Cell)

 

[jolivanes]

Re: "Basically trying to have it so if any part of an order has a 1 in column J then paste all rows that include that order # into new sheet"
Why do you have a 1 twice with Order #55084 in Post #7?

 

[Giovanni03]

Try this:
Data start at row 2
Make sure "Sheet2" exist.

Sub Giovanni03()
Dim i As Long, h As Long, n As Long
Dim va, vb
Dim d As Object

n = Range("D" & Rows.Count).End(xlUp).Row
'Data start at row 2
va = Range("D2:D" & n)
vb = Range("J2:J" & n)

Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare
   
    For i = 1 To UBound(vb, 1)
        If vb(i, 1) = 1 Then d(va(i, 1)) = Empty
    Next

    For i = 1 To UBound(va, 1)
        If d.exists(va(i, 1)) Then vb(i, 1) = 1
    Next

Range("K2").Resize(UBound(vb, 1), 1) = vb

Range("A1:K" & n).Sort Key1:=Columns(11), Order1:=xlAscending, Header:=xlYes

h = WorksheetFunction.Sum(Range("K1:K" & n))
'copy data to Sheet2
Range("A2").Resize(h, 9).Copy Sheets("Sheet2").Range("A1")


End Sub

Oh Man this code is Super close!!!
Definitely excited to see it in action the only thing (and its my fault for not previously mentioning) is that my headers on the sheet that I use this on start on the second row and the third is where the data begins. When I run the code my headers disappear to and get sorted down to the end of the last row that was copied. Also where its being pasted into (sheet 2) also has headers which is getting pasted over.

 

[Giovanni03]

Re: "Basically trying to have it so if any part of an order has a 1 in column J then paste all rows that include that order # into new sheet"
Why do you have a 1 twice with Order #55084 in Post #7?

That order has two items that are identified when i highlight the specific items im looking for.

 

[Akuini]

my headers on the sheet that I use this on start on the second row and the third is where the data begins.

If data start at row 3 then:

Sub Giovanni03_1()
Dim i As Long, h As Long, n As Long
Dim va, vb
Dim d As Object


n = Range("D" & Rows.Count).End(xlUp).Row
'Data start at row 3
va = Range("D3:D" & n)
vb = Range("J3:J" & n)

Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare
    
    For i = 1 To UBound(vb, 1)
        If vb(i, 1) = 1 Then d(va(i, 1)) = Empty
    Next

    For i = 1 To UBound(va, 1)
        If d.exists(va(i, 1)) Then vb(i, 1) = 1
    Next

Range("K3").Resize(UBound(vb, 1), 1) = vb

Range("A2:K" & n).Sort Key1:=Columns(11), Order1:=xlAscending, Header:=xlYes

h = WorksheetFunction.Sum(Range("K1:K" & n))

Range("A3").Resize(h, 9).Copy Sheets("Sheet2").Range("A1")


End Sub

 

[Giovanni03]

If data start at row 3 then:

Sub Giovanni03_1()
Dim i As Long, h As Long, n As Long
Dim va, vb
Dim d As Object


n = Range("D" & Rows.Count).End(xlUp).Row
'Data start at row 3
va = Range("D3:D" & n)
vb = Range("J3:J" & n)

Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare
   
    For i = 1 To UBound(vb, 1)
        If vb(i, 1) = 1 Then d(va(i, 1)) = Empty
    Next

    For i = 1 To UBound(va, 1)
        If d.exists(va(i, 1)) Then vb(i, 1) = 1
    Next

Range("K3").Resize(UBound(vb, 1), 1) = vb

Range("A2:K" & n).Sort Key1:=Columns(11), Order1:=xlAscending, Header:=xlYes

h = WorksheetFunction.Sum(Range("K1:K" & n))

Range("A3").Resize(h, 9).Copy Sheets("Sheet2").Range("A1")


End Sub

Thank you so much for you help!!! it works perfectly!!!!

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.