Column A will always have the date and time in the pictured format, in 1 minute intervals for a whole month.
My first goal is to hide any rows that have a number less than 50 in column B.
Sub HideRows()
Application.ScreenUpdating = False
Application.Calculation = xlManual
For Each c In Range("B:B")
If c.Value < 50 And c.Value <> "" Then Rows(c.Row).Hidden = True
Next
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
That Macro works.
Then, I would also like to hide any consecutive rows that are between the first row starting with a number higher than 50, and the last row higher than 50.
Essentially, it would give me a start and stop time in column A for the flows over 50 in column B.
I don't know enough about coding to hide the times in-between the start and stop times.
Any help/suggestions are greatly appreciated!
Not the most elegant solution, but try this out
Sub StartEnd()
Dim ws As Worksheet
Dim lRow As Long
Dim rng As Range
Dim c As Range
Dim cnt As Long
Dim cntTotal As Long
Set ws = ActiveSheet 'change sheet here if you want
With ws
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row
Set rng = .Range("B2:B" & lRow) 'excluding headers
cntTotal = Application.CountIf(rng, ">50") 'total occurences >50
For Each c In rng
If IsNumeric(c.value) And c.value > 50 Then
cnt = cnt + 1
Select Case cnt
Case 1, cntTotal: 'do nothing if first or last occurence
Case Else: .Rows(c.Row).Hidden = True 'else hide row
End Select
Else
.Rows(c.Row).Hidden = True 'hide row if <50
End If
Next
End With
End Sub
Here's one way, just for the main logic you're looking for:
Dim in50Block As Boolean
in50Block = False
For Each c In Range("B2:B10000")
If c.Value < 50 And c.Value <> "" Then
Rows(c.Row).Hidden = True
in50Block = False
Else
If in50Block = True And c.Offset(1, 0).Value >= 50 Then
Rows(c.Row).Hidden = True
Else
in50Block = True
End If
End If
Next
Related
I need to speed up this macro & to avoid specifying a range as (A2:A2000) for example because my data is dynamic.
My macro checks every cell with the same value in some columns to merge it
Sub Merge_Duplicated_Cells()
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Cell As Range
' Merge Duplicated Cells
Application.DisplayAlerts = False
Sheets("1").Select
Set myrange = Range("A2:A2000, B2:B2000, L2:L2000, M2:M2000, N2:N2000, O2:O2000")
CheckAgain:
For Each Cell In myrange
If Cell.Value = Cell.Offset(1, 0).Value And Not IsEmpty(Cell) Then
Range(Cell, Cell.Offset(1, 0)).Merge
Cell.VerticalAlignment = xlCenter
GoTo CheckAgain
End If
Next
Sheets("2").Select
Set myrange = Range("A2:A2000, B2:B2000, L2:L2000, M2:M2000, N2:N2000, O2:O2000")
For Each Cell In myrange
If Cell.Value = Cell.Offset(1, 0).Value And Not IsEmpty(Cell) Then
Range(Cell, Cell.Offset(1, 0)).Merge
Cell.VerticalAlignment = xlCenter
GoTo CheckAgain
End If
Next
ActiveWorkbook.Save
MsgBox "Report is ready"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
For a quick fix add
Application.Calculation = xlManual
after your code
Application.DisplayAlerts = False
Application.ScreenUpdating = False
and
Application.Calculation = xlAutomatic
after your code
Application.DisplayAlerts = True
Application.ScreenUpdating = True
and to improve the macro not processing blank ranges,
dim ws as worksheet
dim lastrowA, lastrowB, lastrow C as long
'Instead of setting last row to 2000, can use the actual last row by eg:
'find last row of data in column A'
lastrowA = ws.Cells(Rows.Count, 1).End(xlUp).Row
'find last row of data in column B'
lastrowB = ws.Cells(Rows.Count, 2).End(xlUp).Row
'find last row of data in column C'
lastrowC = ws.Cells(Rows.Count, 3).End(xlUp).Row
and insert these into the macro instead of 2000 eg:
Set myrange = Range("A2:A" & lastrowA & ,
The slowdown in your code is primarily due to the presence of the GoTo CheckAgain transition, due to which the cycle of processing the same cells is repeated many times. In addition, multiple calls to the cells of the sheet are used, which is very time consuming. In the code below, unnecessary cycles are excluded, reading data from the sheet, merging and formatting cells are performed immediately for the entire processed subrange.
I ran the code on 2 sheets with 10000 rows each, it took 2.6 sec.
Option Explicit
Sub test1()
'Here we indicate only the starting cells in each column, because
'the size of the non-empty area in these columns is calculated
'automatically in the MergeCells() procedure
MergeCells Sheets("1").Range("A2,B2,L2,M2,N2,O2")
MergeCells Sheets("2").Range("A2,B2,L2,M2,N2,O2")
End Sub
Sub MergeCells(myrange As Range)
Dim v As Variant, col As Range, Cell As Range, toMerge(0 To 1) As Range, k As Long, index As Byte, area As Variant, arr As Variant, skip As Boolean
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
For Each col In myrange
' next line reads all the data from sheet's column at once
arr = col.Resize(myrange.Parent.Cells(Rows.Count, col.Column).End(xlUp).Row - col.Row + 1)
For k = LBound(arr, 1) To UBound(arr, 1) - 1 'loop through all rows of an array
If Not skip And arr(k, 1) = arr(k + 1, 1) And Not IsEmpty(arr(k, 1)) Then
'to prevent "gluing" adjacent sub-ranges within the same range,
'two ranges are used in the toMerge array, all odd sub-ranges are collected
'in the element with index 0, all even ranges are collected in the element
'with index 1, and Index switches from 0 to 1 and vice versa after each array subrange
If toMerge(index) Is Nothing Then
Set toMerge(index) = col.Offset(k - col.Row + 1).Resize(2)
Else
Set toMerge(index) = Union(col.Offset(k - col.Row + 1).Resize(2), toMerge(index))
End If
index = 1 - index
skip = True ' if merged, skip next cell
Else
skip = False
End If
Next
' if the ranges for merge are non-empty, we merge and format simultaneously for all subranges
For Each area In toMerge
If Not area Is Nothing Then
area.Merge
area.VerticalAlignment = XlVAlign.xlVAlignCenter
End If
Next
Set toMerge(0) = Nothing
Set toMerge(1) = Nothing
Next
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
If I understand you correctly .... besides the already existing answer, another way (which is not meant to be better) maybe something like this :
Before and after running the sub (please ignore the yellow fill and the border, as it is used just to be easier to see the result) like image below :
===>
Sub test()
Dim LR As Integer: Dim cnt As Integer
Dim i As Integer: Dim c As Range
Application.DisplayAlerts = False
With ActiveSheet.UsedRange
LR = .Rows(.Rows.Count).Row
cnt = .Columns.Count
End With
For i = 1 To cnt
Set c = Cells(1, i)
Do
If c.Value <> "" And c.Value = c.Offset(1, 0).Value _
Then Range(c, c.Offset(1, 0)).Merge _
Else Set c = c.Offset(1, 0)
Loop Until c.Row > LR
Next
End Sub
LR is the last row of the used range of the active sheet.
cnt is the column count of the used range of the active sheet.
Then it loop from 1 to as many as the cnt as i variable.
Inside this loop, it create the starting cell as c variable, then do the inner loop, by checking each c within the looped column (the i in cnt) if the row below c has the same value then it merge this c and the c.offset(1,0). The inner loop stop when the c.row is larger than the LR, then it goes to the next i (the next column).
Please note, the data should start from column A ... because the outer loop assume that the column to be in the inner loop will start from column 1 (column A). And also, the code doesn't do any fancy things, such as alignment, font size, border, etc.
I would like to delete all empty columns between 2 used ranges, based on the screenshot:
However, these two used ranges may have varying column length, thus the empty columns are not always Columns D to K.
Here is my code:
Sub MyColumns()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.Open ("BOOK2.xlsx")
Workbooks("BOOK2.xlsx").Activate
Workbooks("BOOK2.xlsx").Sheets(1).Activate
Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, 4).Value = "NON-EMPTY"
Dim finalfilledcolumn As Long
finalfilledcolumn = Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
Dim iCol As Long
Dim i As Long
iCol = firstfilledcolumn + 1
'Loop to delete empty columns
For i = 1 To firstfilledcolumn + 1
Columns(iCol).EntireColumn.Delete
Next i
Workbooks("BOOK2.xlsx").Close SaveChanges:=True
MsgBox "DONE!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
However, the empty columns still remain.
Do note that the last filled column for the first used range, Place = "USA", Price = "110" and Category = "Mechanical" may not be fixed at Column C, but could go to Column D, E, etc.
Many thanks!
Please, try the next way:
Sub deleteEmptyColumn()
Dim sh As Worksheet, lastCol As Long, rngColDel As Range, i As Long
Set sh = ActiveSheet 'use here your necessary sheet, having the workbook open
'if not open, you can handle this part...
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column
For i = 1 To lastCol
If WorksheetFunction.CountA(sh.Columns(i)) = 0 Then
If rngColDel Is Nothing Then
Set rngColDel = sh.cells(1, i)
Else
Set rngColDel = Union(rngColDel, sh.cells(1, i))
End If
End If
Next i
If Not rngColDel Is Nothing Then rngColDel.EntireColumn.Delete
End Sub
Try this ..
Dim rng As Range, i As Long
Set rng = Workbooks("BOOK2.xlsx").Sheets(1).UsedRange
For i = rng.Columns.Count To 1 Step -1
If WorksheetFunction.CountA(rng.Columns(i)) = 0 Then
rng.Columns(i).EntireColumn.Delete
End If
Next i
let's say i have a worksheet with 5 columns and ~30,000 - two of those columns are timestamp formatted. both the TS columns have ~300 blank cells, which i would like to populate with a dummy TS value (1900-01-01 00:00:00) for later filtering. if i inserted an extra column for an IF statement, the formula would look like this, of course:
=IF(B2="","1900-01-01 00:00:00",B2)
however, i would rather use a macro to loop through both TS columns (let's define that range as B2:B30000, C2:C30000).
any help is much appreciated. thanks!
Hopefully it will solve your issue.
Option Explicit
Sub Fill_In_Value()
'Turn off following processes to speed up code
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
Dim i As Long
Dim lRow As Long
Dim Column1 As Long
Dim Column2 As Long
Column1 = 1 '1 = To Column A, this setup is easier to change the column later on
Column2 = 2 '2 = To Column B
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Set the worksheetname
lRow = ws.Cells(Rows.Count, "A").End(xlUp).Row 'Find the last row in Column A
For i = 2 To lRow 'Loop from row 2 to last row
If ws.Cells(i, Column1) = "" Or ws.Cells(i, "B") = "" Then 'If any of the column A or column B is empty then:
If ws.Cells(i, Column1) = "" Then 'If column A have blank value then:
ws.Cells(i, Column1).Value = "1900-01-01 00:00:00" 'Add dummy value
If ws.Cells(i, Column2) = "" Then 'If column A have blank value, also check column B.
ws.Cells(i, Column2).Value = "1900-01-01 00:00:00" 'Add dummy value
End If
ElseIf ws.Cells(i, Column2) = "" Then 'If Column A is not blank, B should be blank
ws.Cells(i, Column2).Value = "1900-01-01 00:00:00"
End If
End If
Next i
'Turn on following processes to get back to normal state
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Complete") 'Message box to show when code is finished
End Sub
Faster version
Sub Fill_In_Value2()
'Turn off following processes to speed up code
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
Dim i As Long
Dim lRow1 As Long
Dim lRow2 As Long
Dim Column1 As Long
Dim Column2 As Long
Column1 = 1 '1 = To Column A, this setup is easier to change the column later on
Column2 = 2 '2 = To Column B
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Set the worksheetname
lRow1 = ws.Cells(Rows.Count, Column1).End(xlUp).Row 'Find the last row in Column A
lRow2 = ws.Cells(Rows.Count, Column2).End(xlUp).Row 'Find the last row in Column B
ws.Range(Cells(2, Column1), Cells(lRow1, Column1)).SpecialCells(xlCellTypeBlanks).Value = "1900-01-01 00:00:00"
ws.Range(Cells(2, Column2), Cells(lRow2, Column2)).SpecialCells(xlCellTypeBlanks).Value = "1900-01-01 00:00:00"
'Turn on following processes to get back to normal state
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Complete") 'Message box to show when code is finished
End Sub
I have a two different worksheets with the same number of rows each one. In column R I have "New" or "Old" depending on the row (this is a dynamic value). What I want to do is, if a row in Worksheet1 contains "Old" in column R, then delete that row in both Worksheet1 and Worksheet2.
Now, I have tried two codes for this:
Dim w1 As Worksheet
Dim w2 As Worksheet
Set w1= Worksheets("Sheet1")
Set w2= Worksheets("Sheet2")
'-----------------------------------------------------
'Code 1
'-----------------------------------------------------
Application.ScreenUpdating = False
For r = w1.UsedRange.Rows.Count To 1 Step -1
If Cells(r, "R") = "Old" Then
w1.Rows(r).EntireRow.Delete
w2.Rows(r).EntireRow.Delete
End If
Next r
Application.ScreenUpdating = True
'-----------------------------------------------------
'Code 2
'-----------------------------------------------------
Dim i As Long
i = 1
Application.ScreenUpdating = False
Do While i <= w1.Range("R1").CurrentRegion.Rows.Count
If InStr(1, w1.Cells(i, 18).Text, "Old", vbTextCompare) > 0 Then
w1.Cells(i, 1).EntireRow.Delete
w2.Cells(i, 1).EntireRow.Delete
Else
i = i + 1
End If
Loop
Application.ScreenUpdating = True
Usually I have +800 rows, so Code 1 works as desired but it sometimes takes too long, like 3 minutes. Code 2 gets stuck so far.
What is an efficient way of doing this?
Delete Rows In Sheets
Implementing Union should considerably speed up the process.
The Code
Sub DeleteRowsInSheets()
Const cSheet1 As Variant = "Sheet1" ' First Worksheet Name/Index
Const cSheet2 As Variant = "Sheet2" ' First Worksheet Name/Index
Const cVntCol As Variant = "R" ' Search Column Letter/Number
Const cStrCriteria As String = "Old" ' Search Criteria String
Dim rngU1 As Range ' Union Range 1
Dim rngU2 As Range ' Union Range 2
Dim LastUR As Long ' Last Used Row
Dim i As Long ' Row Counter
With Worksheets(cSheet1)
' Calculate Last Used Row.
If .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
Is Nothing Then Exit Sub
LastUR = .Cells.Find("*", , , , , 2).Row
' Add found cells to Union Ranges.
For i = 1 To LastUR
If StrComp(.Cells(i, cVntCol), cStrCriteria, vbTextCompare) = 0 Then
If Not rngU1 Is Nothing Then
Set rngU1 = Union(rngU1, .Cells(i, 1))
Set rngU2 = Union(rngU2, Worksheets(cSheet2).Cells(i, 1))
Else
Set rngU1 = .Cells(i, 1)
Set rngU2 = Worksheets(cSheet2).Cells(i, 1)
End If
End If
Next
End With
' Delete rows.
If Not rngU1 Is Nothing Then
rngU1.EntireRow.Delete ' Hidden = True
rngU2.EntireRow.Delete ' Hidden = True
Set rngU2 = Nothing
Set rngU1 = Nothing
End If
End Sub
I think that there could be lots of formulas. So Application.Calculation = xlManual at the begining and Application.Calculation = xlCalculationAutomatic at the end should be good idea too.
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For r = w1.UsedRange.Rows.Count To 1 Step -1
If Cells(r, "R") = "Old" Then
w1.Rows(r).EntireRow.Delete
w2.Rows(r).EntireRow.Delete
End If
Next r
Application.ScreenUpdating = true
Application.Calculation = xlCalculationAutomatic
I would like to automate the merging of cells based by column for multiple columns based on the information in a specific column.
Based on the below picture the values in column c will determine the number of rows that need to be merged together for Columns A through K. With each change in the value in Column C - the merging would begin again.
Private Sub MergeCells_C()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("C1:C1000") 'Set the range limits here
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This worked for me:
Sub MergeCellsByC()
Dim c As Range, sht As Worksheet, currV
Dim n As Long, rw As Range, r As Range
Set sht = ActiveSheet
Set c = sht.Range("C4") 'adjust to suit....
currV = Chr(0) 'start with a dummy value
Do
If c.Value <> currV Then
If n > 1 Then
Set rw = c.EntireRow.Range("A1:K1") 'A1:K1 relative to the row we're on...
Application.DisplayAlerts = False
'loop across the row and merge the cells above
For Each r In rw.Cells
r.Offset(-n).Resize(n).Merge
Next r
Application.DisplayAlerts = True
End If
currV = c.Value
n = 1
Else
n = n + 1 'increment count for this value
End If
If Len(c.Value) = 0 Then Exit Do 'exit on first empty cell
Set c = c.Offset(1, 0) 'next row down
Loop
End Sub