I have a sheet (Sheet3) within a workbook that I would like to write VBA to hide multiple rows based on cell value in multiple ranges. The VBA would have to run through two different steps; the first would be if the first cell within the specified range is blank then hide the entire range (except range 1 since the first cell would never be blank). The second step would be if the first cell in range is not blank, then hide rows in that range that are blank. Here are the specifics:
Range 1
A11:A60 - Hide rows that are blank in range
Range 2
A71:A120 - If cell A71 is blank, Hide A71:A120. Otherwise hide all rows that are blank in range A71:A120.
Range 3
A131:A180 - If cell A131 is blank, Hide A131:A180. Otherwise hide all rows that are blank in range A131:A180.
Range 4
A191:A240 - If cell A191 is blank, Hide A191:A240. Otherwise hide all rows that are blank in range A191:A240.
Range 5
A251:A300 - If cell A251 is blank, Hide A251:A300. Otherwise hide all rows that are blank in range A251:A300.
Public Sub HideRowsSummary()
Dim wsMySheet As Worksheet
Dim lngMyRow As Long, unionRng As Range
Application.ScreenUpdating = False
For Each wsMySheet In ThisWorkbook.Sheets
Select Case wsMySheet.Name
Case Is = Sheet3
.Range("A11:A60", "A71:A120", "A131:A180", "A191:A240", "A251:A300").EntireRow.Hidden = False
For lngMyRow = 11 To 60
If Len(.Range("A" & lngMyRow)) = 0 Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, .Range("A" & lngMyRow))
Else
Set unionRng = .Range("A" & lngMyRow)
End If
End If
Next lngMyRow
End With
End Select
If Not unionRng Is Nothing Then unionRng.EntireRow.Hidden = True
Set unionRng = Nothing
Next wsMySheet
Application.ScreenUpdating = True
End Sub
In your question #2, 3, 4, 5 all follow similar logic.
The first i loop tackles #1. The next portion of the code tackles #2. You can simply copy/paste the bottom portion and change your test values to complete your ask.
Option Explicit
Sub HideMe()
Dim i As Integer
With ThisWorkbook.Sheets("Sheet3")
For i = 11 To 60
.Range("A" & i).EntireRow.Hidden = .Range("A" & i) = vbNullString
Next i
'Repeat this portion for you other ranges that follow the same rules
If .Range("A" & 71) = vbNullString Then
.Range("A71:A120").EntireRow.Hidden = True
Else
For i = 72 To 120
.Range("A" & i).EntireRow.Hidden = .Range("A" & i) = vbNullString
Next i
End If
End With
End Sub
This can be improved by
A) Use For Each loop instead of For i loop
B) Instead of hiding rows one by one, add them to a collection of rows as a (Union) and hide the Union all at once
Related
I just want to know how to loop through the non blank cells on Column A. What I'm trying to do is copy the contents on [A1:B1] to be added on top of each non blank cells on Column A. So far I have counted the non blank cells on column A but I'm stuck. I know that an Offset function should be used for this.
Here's my code so far:
Dim NonBlank as Long
NonBlank = WorksheetFunction.CountA(Worksheet(1).[A:A])
For i = 1 to NonBlank
[A1:B1].Copy Offset(1,0). "I'm stuck here"
Next i
If you are trying to fill the headers for each Product, try this...
Sub FillHeaders()
Dim lr As Long
Dim Rng As Range
lr = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
On Error Resume Next
Range("A1:B1").Copy
For Each Rng In Range("A3:A" & lr).SpecialCells(xlCellTypeConstants, 2).Areas
If Rng.Cells(1).Value <> Range("A1").Value Then
Rng.Cells(1).Offset(-1, 0).PasteSpecial xlPasteAll
End If
Next Rng
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
As example to simulate the effect of Ctrl-Down from Cell A1 and display the Address, Value in the Immediate Window:
Sub HopToNextNonBlankCellBelow()
Dim oRng As Range
Set oRng = Range("A1")
Debug.Print "Cell Address", "Cell Value"
Do
Set oRng = oRng.End(xlDown)
If Not IsEmpty(oRng) Then Debug.Print oRng.Address(0, 0), oRng.Value
Loop Until oRng.Row = Rows.Count
Set oRng = Nothing
End Sub
Try this... I've (probably) overcounted the rows at 1000, but it likely won't make a difference with your performance. If you wanted to be more precise, there are hundreds of articles on how to find the last row of a range. As for the Offset function, it references a cell in relation to the one we're looping through. In the example below, the code is saying cell.offset(0,1) which means one cell to the right of the cell we are currently looping through. A clearer (less loopy!) example would be if you typed: Range("A10").offset(0,1) it would be the same as typing Range("B10")
Dim Cell As Range
For Each Cell In Range("A2:A1000").Cells
If Not IsEmpty(Cell) Then
Cell.Offset(0, 1).Value = Cell.Value
End If
Next Cell
I'm having a difficult time merging code to accomplish my goal. I am working between two sheets within one workbook. Column "A" references an item that may have multiple rows in column "C". "C" could have thousands of label codes, but there are 52 label codes that are listed in sheet "SheetCode". What my goal is to look at an item and see if it has one of the 52 label codes and if so then remove the item and all rows below it until the next Item in Column "A" label number. I want my macro to:
Search Column C for any value listed in sheet "SheetCode" (A2:A53)
If found, reference the associated populated cell in Column A and delete all rows below until it runs into the next populated cell in Column A, but continues to search the rest of column "C" for more (A2:A53) values.
Loop
I posted 2 images. The SheetCode worksheet has the list of values. I adde conditional formatting so that any cell value in main spreadsheet is colored. Ultimately the code should then delete all rows below the Column A value. This example would show rows 14-21 and 29-44 deleted.
Here is what I have so far. My problem is I want to avoid
Sub Remove_TBI_AB()
Const TEST_COLUMN As String = "C"
Dim Lastrow As Long
Dim EndRow As Long
Dim i As Long
Application.ScreenUpdating = False
With ActiveSheet
Lastrow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
EndRow = Lastrow
For i = Lastrow To 1 Step -1
If .Cells(i, TEST_COLUMN).Value2 Like "161000" Then
'Here I could at continuous "_or" and then in next line add the next code to find, but I have the list and would rather reference the list of values
.Rows(i & ":" & EndRow).Delete
EndRow = i - 1
' Here I need code to delete all cells below the associated value in Column A until the next populated cell.
EndRow = i - 1
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
SheetCode; values to target
Main Worksheet
You're on the right track, with some use of arrays and worksheet functions it could be completed; the key is that we will iterate backward "by item zone" instead of by individual rows. For each item zone, if at least one code is matched in the SheetCode list, the whole zone is deleted.
Sub Remove_TBI_AB()
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
On Error GoTo Cleanup
Dim codes As Range: Set codes = Worksheets("Sheetcode").Range("A2:A53")
Dim lastrow As Long, startRow As Long
'[startRow, lastRow] mark the start/end of current item
With Worksheets("Main")
lastrow = .Cells(.Rows.count, 3).End(xlUp).row
Do While lastrow > 1
startRow = lastrow
Do Until Len(Trim(.Cells(startRow, 1).Value2)) > 0
startRow = startRow - 1
Loop ' find the beginning of current item
With .Range("C" & startRow & ":C" & lastrow) ' range of current item codes
If Application.SumProduct(Application.CountIf(codes, .Value2)) > 0 Then
.EntireRow.Delete ' at least one code was matched
End If
End With
lastrow = startRow - 1
Loop ' restart with next item above
End With
Cleanup:
Application.ScreenUpdating = False: Application.Calculation = xlCalculationAutomatic
End Sub
I'm making a simple subtraction between two cells that contain dates in order to obtain the period. Every client, in Data_p worksheet, Range ("4"), will have all the order dates in the respective column. So the subtraction will be between the second date and the first, and so on, and the result will be pasted in Data_p_mgnt. This function will have to be executed until there're no more dates for each client.
I have the following code, but I don't know why it won't stop when it finds and Empty cell in Data_p. Any insight will be appreciated.
Sub Prueba_Data_p_mgnt()
Sheets("Data_p_mgnt").Select
Range("B5").Select 'Starts in cell B5
Do Until IsEmpty(Worksheets("Data_p").Range("B5")) 'Checks if cells in Data_p are Empty or Blank
ActiveCell.FormulaR1C1 = "=Data_p!R[1]C-Data_p!RC" 'Makes the subtraction between cells
ActiveCell.Offset(1, 0).Range("A1").Select 'Moves down for paste the next period
Loop 'Loop until there's an Empty cell in Data_p
'Then should move to next client to the right and repeat until there are no more clients in row 4
End Sub
I believe this is what you are trying to do:
Sub Prueba_Data_p_mgnt()
Dim wsMgnt As Worksheet
Dim wsData As Worksheet
Dim rowNo As Long
Dim colNo As Long
Set wsMgnt = Worksheets("Data_p_mgnt")
Set wsData = Worksheets("Data_p")
colNo = 2
Do Until IsEmpty(wsData.Cells(4, colNo)) 'Checks if cells in Data_p are Empty or Blank
rowNo = 5
Do Until IsEmpty(wsData.Cells(rowNo, colNo)) 'Checks if cells in Data_p are Empty or Blank
'Alternatively, to avoid subtracting the last non-blank cell from a blank cell
'Do Until IsEmpty(wsData.Cells(rowNo + 1, colNo)) 'Checks if cells in Data_p are Empty or Blank
wsMgnt.Cells(rowNo, colNo).FormulaR1C1 = "=Data_p!R[1]C-Data_p!RC" 'Makes the subtraction between cells
'Alternatively, if you would rather have values than formulae
'wsMgnt.Cells(rowNo, colNo).Value = wsData.Cells(rowNo + 1, colNo).Value - wsData.Cells(rowNo, colNo).Value
rowNo = rowNo + 1 'Moves down for paste the next period
Loop 'Loop until there's an Empty cell in Data_p
colNo = colNo + 1 'Then should move to next client to the right and repeat until there are no more clients in row 4
Loop
End Sub
This should, I hope, do the trick:
Sub Prueba_Data_p_mgnt()
Dim dataWS As Worksheet
Dim rng As Range
Set dataWS = Sheets("Data_p_mgnt")
Set rng = dataWS.Range("B5") ' what's this? You never use data_p_mgnt cell B5?
For i = 5 To 100 ' Change 100 to whatever you need
If Not IsEmpty(Worksheets("Data_p").Range("b" & i)) Then 'Checks if cells in Data_p are Empty or Blank
Worksheets("Data_p").Range("b" & i).FormulaR1C1 = "=Data_p!R[1]C-Data_p!RC" 'Makes the subtraction between cells
End If 'Loop until there's an Empty cell in Data_p
Next i
End Sub
But looking at your code, I don't know what you plan on doing with B5 on the Data_p_mgnt sheet.
I am attempting to do a simple copy row, paste row within a workbook. I've searched threads and tried changing my code multiple times to no avail.
The one that comes closest to working is this but it only copies a single instance of matching criteria.
I am trying to create a loop that will copy all of the rows that has a match in one of the columns.
So, if 8 columns, each row with matching value in column 7 should copy to a named sheet.
Sub test()
Set MR = Sheets("Main").Range("H1:H1000")
Dim WOLastRow As Long, Iter As Long
For Each cell In MR
If cell.Value = "X" Then
cell.EntireRow.Copy
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Y" Then
cell.EntireRow.Copy
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Z" Then
cell.EntireRow.Copy
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "AB" Then
cell.EntireRow.Copy
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
I like this because I need to target multiple destination sheets with different criteria but I need all rows that match criteria to copy over.
EDITED CODE IN RESPONSE TO NEW REQUEST:
The code below will copy all of the rows in Sheet Main and paste them into the corresponding worksheets based on the value in Column 7.
Do note: If there is a value in Column 7 that does NOT match to an existing sheet name, the code will throw an error. Modify the code to handle that exception.
Let me know of any additional needed help.
Sub CopyStuff()
Dim wsMain As Worksheet
Dim wsPaste As Worksheet
Dim rngCopy As Range
Dim nLastRow As Long
Dim nPasteRow As Long
Dim rngCell As Range
Dim ws As Worksheet
Const COLUMN_TO_LOOP As Integer = 7
Application.ScreenUpdating = False
Set wsMain = Worksheets("Main")
nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
Set rngCopy = wsMain.Range("A2:H" & nLastRow)
For Each ws In ActiveWorkbook.Worksheets
If UCase(ws.Name) = "MAIN" Then
'Do Nothing for now
Else
Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents
End If
Next ws
For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP))
On Error Resume Next
Set wsPaste = Worksheets(rngCell.Value)
On Error GoTo 0
If wsPaste Is Nothing Then
MsgBox ("Sheet name: " & rngCell.Value & " does not exist")
Else
nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1)
End If
Set wsPaste = Nothing
Next rngCell
Application.ScreenUpdating = True
End Sub
Your current code is pasting to the same row in each sheet over and over, to the last row with a value in column A. Range("A" & Rows.Count).End(xlUp) says, roughly "go to the very bottom of the spreadsheet in column A, and then jump up from there to the next lowest cell in column A with contents," which gets you back to the same cell each time.
Instead, you could use lines of the pattern:
Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial
Where UsedRange is a range containing all of the cells on the sheet with data in them. The + 1 puts you on the following row.
You could make this a little prettier using With:
With Sheets("X")
.Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial
End With
I have a VBA Excel code with that checks values in a specific column. If the row in that column contains the value 'Delete' and then deletes the row.
The code works well, but it is really slow. Any ideas on how to get the code run faster?
Dim rng1 As Range
Dim i As Integer, counter As Integer
'Set the range to evaluate to rng.
Set rng1 = Range("g1:g1000")
'initialize i to 1
i = 1
'Loop for a count of 1 to the number of rows
'in the range that you want to evaluate.
For counter = 1 To rng1.Rows.Count
'If cell i in the range1 contains an "Delete"
'delete the row.
'Else increment i
If rng1.Cells(i) = "Delete" Then
rng1.Cells(i).EntireRow.Delete
Else
i = i + 1
End If
Next
Thanks
c.
Sub deletingroutine()
Dim r As Range
For Each r In Range("g1:g1000")
If r = "delete" Then r.EntireRow.Delete
Next r
End Sub
I managed to find a solution with the Autofilter function.
Hope it helps someone
Selection.AutoFilter
Set ws = ActiveWorkbook.Sheets("UploadSummary")
lastRow = ws.Range("G" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("G1:G" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=7, Criteria1:="delete" ' 7 refers to the 7th column
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Try sorting the rows (on collumn G) then deleting all marked ("delete") rows in one action. That is much faster.