Loop through worksheet and set value of highlighted rows on other sheet

D

DrParmeJohnson

New Member
Joined
Feb 28, 2019
Messages
44
Hello,
I am trying to make this macro work as it only works partly now.

VBA Code: 
Sub LP_Order()


'Highlight OutOfStocks based on user input

Application.Run "PERSONAL.XLSB!dHighlightCells"

'Take Highlighted OOS's and cut them onto a new Sheet

Dim i As Integer
Dim exists As Boolean

For i = 1 To Worksheets.Count
    If Worksheets(i).Name = "Out Of Stocks" Then
        exists = True
    End If
Next i

If Not exists Then
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Out Of Stocks"
End If

Dim c As Range
Dim Lastrow As Integer
Dim Lastrow2 As Integer
Dim ws1 As Worksheet
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Lastrow2 = Worksheets("Out Of Stocks").Cells(Rows.Count, "A").End(xlUp).Row
Set ws1 = Worksheets(1)
Range("C$2:C" & Lastrow).Value = Range("C$2:C" & Lastrow).Value
Range("D$2:E" & Lastrow).EntireColumn.Delete
Worksheets("Out Of Stocks").Range("A1").Value = "id"
Worksheets("Out Of Stocks").Range("B1").Value = "Description"
Worksheets("Out Of Stocks").Range("C1").Value = "Qty"


For Each c In ws1.Range("A$2:C" & Lastrow)
    If c.Interior.Color = vbYellow Then
    Worksheets("Out of Stocks").Range("A$2:C" & Lastrow2).Offset(1, 0).Value = c.EntireRow.Value
    End If
Next c

Worksheets("Out Of Stocks").Cells.EntireColumn.AutoFit
Application.CutCopyMode = False



End Sub

The function is as follows:
It first prompts the user to select which range to highlight yellow.
It then checks for a sheet and if it doesn't exist, it adds it.
The next part gets weird and I don't know where I go wrong.

What I'm trying to make happen is for the macro to loop through Range("A$2:C" & Lastrow), find all the highlighted rows, copy their entire value (just 3 cells A#,B#,C#) to a second sheet ("Out of Stocks") and on that second sheet copy each row to a row below the "Lastrow2" (Last row on 2nd sheet) and do so until there are no more highlight columns.
I would also like to add a part that deletes the entirerow that is highlighted after it has been copied to the other sheet.
Both sheets (the first and second) look like this:
But the second sheet is blank and only contains the names in A1, B1, C1.
idDescriptionqty
1000name15
1500name27
2000name310

When I run the macro now, it only copies the first value that was highlighted (I think). It seems a bit picky in that sense.

I'm not sure what the issue is, so if anyone can assist, I would appreciate it greatly.

Thanks.
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Sort by date Sort by votes
How about
VBA Code: 
Sub LP_Order()


   'Highlight OutOfStocks based on user input
   
   Application.Run "PERSONAL.XLSB!dHighlightCells"
   
   'Take Highlighted OOS's and cut them onto a new Sheet
   
   If Not Evaluate("Isref('Out Of Stocks'!A1)") Then
       Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Out Of Stocks"
   End If
   
   Dim Cl As Range
   Dim Lastrow As Integer
   Dim ws1 As Worksheet
   
   Set ws1 = Worksheets(1)
   Lastrow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
   ws1.Range("C2:C" & Lastrow).Value = ws1.Range("C2:C" & Lastrow).Value
   ws1.Range("D:E").EntireColumn.Delete
   
   With Worksheets("Out Of Stocks")
      .Range("A1").Value = "id"
      .Range("B1").Value = "Description"
      .Range("C1").Value = "Qty"
   
      For Each Cl In ws1.Range("A2:A" & lstRow)
         If c.Interior.Color = vbYellow Then
            .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = Cl.Resize(, 3).Value
         End If
      Next Cl
   
      .Cells.EntireColumn.AutoFit
   End With
   Application.CutCopyMode = False
   
End Sub
 
Upvote 0
Thanks for the response, I’ll let you know on Monday how it works as this is a work thing. I appreciate it nonetheless.
 
Upvote 0
Hi Fluff, Happy New Year!
A couple of details in this part:
Fluff said:
Rich (BB code): 
      For Each Cl In ws1.Range("A2:A" & lstRow)  'must be Lastrow 
         If c.Interior.Color = vbYellow Then 'must be Cl
            .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = Cl.Resize(, 3).Value
         End If
      Next Cl
Click to expand...
__________________________________________________
Here is another approach to copy highlighted rows for you to consider

VBA Code: 
Sub LP_Order()
   'Highlight OutOfStocks based on user input
   Application.Run "PERSONAL.XLSB!dHighlightCells"
   'Take Highlighted OOS's and cut them onto a new Sheet
   
   Application.ScreenUpdating = False
   If Not Evaluate("Isref('Out Of Stocks'!A1)") Then
       Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Out Of Stocks"
   End If
   
   Dim Lastrow As Integer
   Dim ws1 As Worksheet
   
   Set ws1 = Worksheets(1)
   Lastrow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
   ws1.Range("C2:C" & Lastrow).Value = ws1.Range("C2:C" & Lastrow).Value
   ws1.Range("D:E").EntireColumn.Delete
   
   With Worksheets("Out Of Stocks")
      .Range("A1").Value = "id"
      .Range("B1").Value = "Description"
      .Range("C1").Value = "Qty"
   
      ws1.Range("A1:C" & Lastrow).AutoFilter 1, RGB(255, 255, 0), xlFilterCellColor
      ws1.AutoFilter.Range.Range("A2:C" & Lastrow).Copy
      .Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
      .Cells.EntireColumn.AutoFit
   End With
   Application.CutCopyMode = False
End Sub
 
Upvote 0
DanteAmor said:
Hi Fluff, Happy New Year!
A couple of details in this part:

__________________________________________________
Here is another approach to copy highlighted rows for you to consider

VBA Code: 
Sub LP_Order()
   'Highlight OutOfStocks based on user input
   Application.Run "PERSONAL.XLSB!dHighlightCells"
   'Take Highlighted OOS's and cut them onto a new Sheet
  
   Application.ScreenUpdating = False
   If Not Evaluate("Isref('Out Of Stocks'!A1)") Then
       Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Out Of Stocks"
   End If
  
   Dim Lastrow As Integer
   Dim ws1 As Worksheet
  
   Set ws1 = Worksheets(1)
   Lastrow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
   ws1.Range("C2:C" & Lastrow).Value = ws1.Range("C2:C" & Lastrow).Value
   ws1.Range("D:E").EntireColumn.Delete
  
   With Worksheets("Out Of Stocks")
      .Range("A1").Value = "id"
      .Range("B1").Value = "Description"
      .Range("C1").Value = "Qty"
  
      ws1.Range("A1:C" & Lastrow).AutoFilter 1, RGB(255, 255, 0), xlFilterCellColor
      ws1.AutoFilter.Range.Range("A2:C" & Lastrow).Copy
      .Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
      .Cells.EntireColumn.AutoFit
   End With
   Application.CutCopyMode = False
End Sub
Click to expand...
Thanks for the response, I’ll give em both a try when I’m back into work Monday.
Appreciate you taking the time.
 
Upvote 0
Fluff said:
How about
VBA Code: 
Sub LP_Order()


   'Highlight OutOfStocks based on user input
  
   Application.Run "PERSONAL.XLSB!dHighlightCells"
  
   'Take Highlighted OOS's and cut them onto a new Sheet
  
   If Not Evaluate("Isref('Out Of Stocks'!A1)") Then
       Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Out Of Stocks"
   End If
  
   Dim Cl As Range
   Dim Lastrow As Integer
   Dim ws1 As Worksheet
  
   Set ws1 = Worksheets(1)
   Lastrow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
   ws1.Range("C2:C" & Lastrow).Value = ws1.Range("C2:C" & Lastrow).Value
   ws1.Range("D:E").EntireColumn.Delete
  
   With Worksheets("Out Of Stocks")
      .Range("A1").Value = "id"
      .Range("B1").Value = "Description"
      .Range("C1").Value = "Qty"
  
      For Each Cl In ws1.Range("A2:A" & lstRow)
         If c.Interior.Color = vbYellow Then
            .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = Cl.Resize(, 3).Value
         End If
      Next Cl
  
      .Cells.EntireColumn.AutoFit
   End With
   Application.CutCopyMode = False
  
End Sub
Click to expand...

Fluff,
I used your code and it worked great. Had to fix two little typos but other than that, worked perfectly.
Would there be an easy way to delete the rows with the Highlighted cells in them easier than just using a for each loop because that's how I planned on doing it.
 
Upvote 0
Add this just before the End Sub
VBA Code: 
      Ws.Range("A1:A" & Lastrow).AutoFilter 1, vbYellow, xlFilterCellColor
      Ws.AutoFilter.Range.Offset(1).EntireRow.Delete
 
Upvote 0
In my option the filter is already done, then just add a line to delete the data.

VBA Code: 
Sub LP_Order()
   'Highlight OutOfStocks based on user input
   Application.Run "PERSONAL.XLSB!dHighlightCells"
   'Take Highlighted OOS's and cut them onto a new Sheet
   
   Application.ScreenUpdating = False
   If Not Evaluate("Isref('Out Of Stocks'!A1)") Then
       Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Out Of Stocks"
   End If
   
   Dim Lastrow As Integer
   Dim ws1 As Worksheet
   
   Set ws1 = Worksheets(1)
   Lastrow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
   ws1.Range("C2:C" & Lastrow).Value = ws1.Range("C2:C" & Lastrow).Value
   ws1.Range("D:E").EntireColumn.Delete
   
   With Worksheets("Out Of Stocks")
      .Range("A1").Value = "id"
      .Range("B1").Value = "Description"
      .Range("C1").Value = "Qty"
   
      ws1.Range("A1:C" & Lastrow).AutoFilter 1, RGB(255, 255, 0), xlFilterCellColor
      ws1.AutoFilter.Range.Range("A2:C" & Lastrow).Copy
      .Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
      .Cells.EntireColumn.AutoFit
      ws1.AutoFilter.Range.Offset(1).EntireRow.Delete
   End With
   Application.CutCopyMode = False
End Sub
 
Upvote 0
Fluff said:
Add this just before the End Sub
VBA Code: 
      Ws.Range("A1:A" & Lastrow).AutoFilter 1, vbYellow, xlFilterCellColor
      Ws.AutoFilter.Range.Offset(1).EntireRow.Delete
Click to expand...
Put that in and it made the data on my main sheet that wasn't highlighted disappear but did also delete the highlighted ones.

Edit: Didn't disappear, just was showing the cells with color but those cells were deleted so it showed nothing and hid the others until I adjusted the filter.
 
Upvote 0
Forgot to add this
VBA Code: 
Ws.Autofiltermode=False
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question
My code is suddenly really slow
Replies
1
Views
137
RobP
R
E
  • Solved
VBA -highlighting rows when a condition is met
Replies
2
Views
174
Evie76
E
A
  • Question
how to add my signature with images to macro
Replies
1
Views
172
Domenic
D
J
  • Solved
VBA to compare rows in two different sheets, if match highlight cell
2
Replies
10
Views
641
kevin9999
K
J
  • Locked
  • Question
Help with code to copy value if criteria is met
Replies
1
Views
132
Fluff
Fluff

Forum statistics

Threads
1,215,056
Messages
6,122,907
Members
449,096
Latest member
dbomb1414

Share this page

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
Back
Top