I have the following code to capitalize all data in two specified ranges and then run some comparing code.
The issue is once it runs the capitalize code cells that contain something like 1-2 gets changed to 2-Jan. I cannot apply .NumberFormat = "#" to the entire worksheet or that specific column because I am making the sheet dynamic and this data won't always be in the same column. Anyone know how to take care of this problem?
Dim rangeToUse As Range, singleArea As Range, cell1 As Range, cell2 As Range, rng As Range, rng2 As Range
Dim I As Integer, J As Integer
'Set two range selections
Set rng = Application.InputBox("Select First Range", "Obtain 1st Range Object", Type:=8)
Set rng2 = Application.InputBox("Select Second Range", "Obtain 2nd Range Object", Type:=8)
Set MultiRange = Union(rng, rng2)
MultiRange.Select
Set rangeToUse = Selection
Cells.Interior.ColorIndex = 0
Cells.Borders.LineStyle = xlNone
'Capitalizes all cells in selected range
'Turn off screen updating to increase performance
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Worksheets("Phase 3 xwire").Range(rangeToUse).NumberFormat = "#"
'Convert all constants and text values to proper case
For Each LCell In Cells.SpecialCells(xlConstants, xlTextValues)
LCell.Formula = UCase(LCell.Formula)
Calculate
Next
If Selection.Areas.Count <= 1 Then
MsgBox "Please select more than one area."
Else
rangeToUse.Interior.ColorIndex = 0
For Each singleArea In rangeToUse.Areas
singleArea.BorderAround ColorIndex:=1, Weight:=xlMedium
Next singleArea
'Areas.count - 1 will avoid trying to compare
' Area(count) to the non-existent area(count+1)
For I = 1 To rangeToUse.Areas.Count - 1
For Each cell1 In rangeToUse.Areas(I)
'I+1 gets you the NEXT area
Set cell2 = rangeToUse.Areas(I + 1).Cells(cell1.Row - 1, cell1.Column - 1)
If IsEmpty(cell2.Value) Then
GoTo Done
Else
If cell1.Value <> cell2.Value Then
cell1.Interior.ColorIndex = 38
cell2.Interior.ColorIndex = 38
End If
End If
Next cell1
Next I
Done:
End If
'Turn screen updating back on
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
If you are keeping the Input Boxes you could add this line of code after your MultiRange.Select command
Selection.NumberFormat = "#"
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'd like to merge identical adjacent cells within a column. Some online examples loop through the column and merge every time the cell below matches, and I'd like to avoid that. Here's my current broken attempt that spits out run-time error 5.
Sub Merge2()
Application.ScreenUpdating = False
Dim rng1 As Range
Dim rng2 As Range
Dim certaincell As Range
Dim LastRow As Long
LastRow = 0
LastRow = Cells(Rows.Count, 35).End(xlUp).Row
Set rng1 = Range(Cells(2, 35), Cells(LastRow, 35))
CheckUnder:
For Each certaincell In rng1
Set rng2 = Union(rng2, certaincell) 'Add the checking cell to the range
If certaincell.Value = certaincell.Offset(1, 0).Value Then 'if the cell is the same as the cell under
'move on to next cell
Else
rng2.Merge 'merge similar cells above
Set rng2 = Nothing
End If
Next
Application.ScreenUpdating = True
End Sub
The variable rng2 is initially set to Nothing. So, adjust your code as follows:
For Each certaincell In rng1
If rng2 Is Nothing Then
Set rng2 = certaincell
End If
Set rng2 = Union(rng2, certaincell) 'Add the checking cell to the range
If certaincell.Value = certaincell.Offset(1, 0).Value Then
Else
rng2.Merge 'merge similar cells above
Set rng2 = Nothing
End If
Next
The if statement will check if the rng2 is nothing and if so, it will assign the currently checked certaincell to the variable.
Also, merging cells with data will pop up some error dialogs. This can be avoided by using Application.DisplayAlerts = False.
Make sure to turn it on using Application.DisplayAlerts = True at the end.
I need to copy a column of visible cells and paste to the next column over.
I can't find a macro that works. I had one going, but it only copies some numbers.
Here is the code
Sub TryMe()
Sheet1.Range("A1:A100").SpecialCells(xlCellTypeVisible).Copy _
Destination:=Range("A1").Offset(ColumnOffset:=1)
End Sub
This image is before I run the macro. Notice the rows that are hidden. I need these numbers to copy to the next column.
This image is after I run the macro. I don't understand why only some of the numbers are copying. The hidden rows contain the numbers 3 and 6. Why are they in the outcome, but not the visible numbers? I need to copy what is seen.
You can't do it that way even if you manually do it.
You will have to loop to get what you want. So give this a try.
Dim c As Range
For Each c In Sheet1.Range("A1:A100").SpecialCells(xlCellTypeVisible)
If Len(c) <> 0 Then c.Offset(0, 1) = c
Next
The odd thing about your result is why does it copy the values in reverse order.
I can understand if it copies all the visible cells at B1 onwards, but not the reversal of values.
Anyways, try above first if it gets you going.
I'm not sure how you have the output in reverse order, but for me your code works:
Sub TryMe()
'1. some visible values in col A will be will be hidden in col B by hidden rows
Sheet1.Range("A1:A10").SpecialCells(xlCellTypeVisible).Copy _
Destination:=Range("A1").Offset(ColumnOffset:=1)
'2. all visible values in col A will be will be visible bellow
Sheet1.Range("A1:A10").SpecialCells(xlCellTypeVisible).Copy _
Destination:=Range("A11").Offset(ColumnOffset:=1)
End Sub
Use this code guys! Works like a charm :)
Sub PasteToFilteredCells()
Dim rng1 As Range
Dim rng2 As Range
Dim InputRng As Range
Dim OutRng As Range
Dim n As Integer
n = 0
Dim x As Integer
Dim c As Integer
c = 0
xTitleId = "Paste Buddy"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Copy Range :", xTitleId, InputRng.Address, Type:=8)
Set OutRng = Application.InputBox("Paste Range:", xTitleId, Type:=8)
x = InputRng.SpecialCells(xlCellTypeVisible).Count
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
For Each rng1 In InputRng
If rng1.EntireRow.RowHeight > 0 Then
rng1.Copy
c = c + 1
Else
GoTo NextIte
End If
Do While (c < (x + 1))
If (OutRng.Offset(n, 0).EntireRow.RowHeight > 0) Then
OutRng.Offset(n, 0).PasteSpecial
n = n + 1
GoTo NextIte
Else
n = n + 1
End If
Loop
NextIte:
Next rng1
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
I'm trying to use a shape instead of a button to toggle hiding rows with blank cells (according to conditions). Is it even possible?
Sub ToggleChevron3_Click()
Dim rng As Range, cell As Range
Set rng = Range("A1:C100")
Application.ScreenUpdating = False
With rng
For Each cell In rng
If cell.Offset(0, 4).Value = "" Then ' Condition 1
If cell.Value = "" Then ' Condition 2
ActiveSheet.Shapes("Chevron 3").cell.EntireRow.Hidden _
= Not ActiveSheet.Shapes("Chevron 3").cell.EntireRow.Hidden
End If
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Yes, it is possible. The code to accomplish what I think you are looking for is below. Both pieces of code below assume you want to just click a button to hide / unhide the rows, depending on the current state.
Sub ToggleChevron3_Click()
Application.ScreenUpdating = False
Dim rng As Range, cell As Range
'Set rng = Range("A1:C100") 'do you really want to loop through every cell in columns A through C
Set rng = Range("A1:A100")
For Each cell In rng
If Len(cell.Offset(, 4).Value) = 0 And Len(cell.Value) = 0 Then
Dim bToggle As Boolean
bToggle = cell.EntireRow.Hidden
cell.EntireRow.Hidden = Not bToggle
End If
Next
Application.ScreenUpdating = True
End Sub
However, there is alternative that is cleaner code and faster execution, as long as filtering is okay for you.
Sub ToggleChevron3_Click()
Application.ScreenUpdating = False
Dim bToggle As Boolean
bToggle = ActiveSheet.AutoFilterMode
If bToggle Then
ActiveSheet.AutoFilterMode = False
Else
Dim rng As Range
Set rng = Range("A1:E100") 'used E because you had an offset of 4 columns
With rng
.AutoFilter 5, "<>"
.AutoFilter 1, "<>"
End With
End If
Application.ScreenUpdating = True
End Sub
I can Select only the Cells with in region that contain numbers:
Region.SpecialCells(xlCellTypeConstants , xlNumbers)
but I don't know how to Select only the cells that are above a number. For example those above 1.0
I have a big Sheet with numbers and I want to cap all numbers above 1, and set them to 1. I would love to do it without having to loop on each cell.
thanks!
This method below avoids the cell by cell loop - while it is significantly longer than your range loop code I share your preference for avoiding cell by cell range loops where possible
I have updated my code from A fast method for determining the unlocked cell range to provide a non cell by cell loop method
the code checks that SpecialCells(xlCellTypeConstants , xlNumbers)
exist on the sheet to be updated (error handling should always be
used with SpecialCells
if these cells exist, a working sheet is created, and a formula is inserted into the range from step 1 to create a deliberate error (the 1/0) if the value on the main sheet is >1
SpecialCells(xlCellTypeFormulas, xlErrors) returns a range of cells from the working sheet where the values were greater than 1 (into rng3)
All areas in rng3 are set to 1 with rng3.Value2=1
Sub QuickUpdate()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim lCalc As Long
Set ws1 = ActiveSheet
On Error Resume Next
Set rng1 = ws1.Cells.SpecialCells(xlConstants, xlNumbers)
On Error GoTo 0
'exit if there are no contants with numbers
If rng1 Is Nothing Then Exit Sub
'disable screenupdating, event code and warning messages.
'set calculation to manual
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
lCalc = .Calculation
.Calculation = xlCalculationManual
End With
ws1.Copy After:=Sheets(Sheets.Count)
Set ws2 = ActiveSheet
'test for cells constants > 1
ws2.Cells.SpecialCells(xlConstants, xlNumbers).FormulaR1C1 = "=IF('" & ws1.Name & "'!RC>1,1/0,'" & ws1.Name & "'!RC)"
On Error Resume Next
Set rng2 = ws2.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If Not rng2 Is Nothing Then
Set rng3 = ws1.Range(rng2.Address)
rng3.Value2 = 1
Else
MsgBox "No constants < 1"
End If
ws2.Delete
'cleanup user interface and settings
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
lCalc = .Calculation
End With
'inform the user of the unlocked cell range
If Not rng3 Is Nothing Then
MsgBox "Cells updated in Sheet " & vbNewLine & ws1.Name & vbNewLine & " are " & vbNewLine & rng3.Address(0, 0)
Else
MsgBox "No cells updated in " & ws1.Name
End If
End Sub
I say, forget about SpecialCells. Just load all cells that need testing into a Variant array. Then loop over that array and do your capping. That is very efficient, contrary to looping over cells in a sheet. Finally, write it back to the sheet.
With 50,000 cells containing random values between 0 and 2, this code ran in 0.2 s on my antique laptop.
The added bonus is that this is quite clear and readable code, and you retain full control over what range will be operated on.
Dim r As Range
Dim v As Variant
Set r = Sheet1.UsedRange
' Or customise it:
'Set r = Sheet1.Range("A1:HZ234") ' or whatever.
v = r ' Load cells to a Variant array
Dim i As Long, j As Long
For i = LBound(v, 1) To UBound(v, 1)
For j = LBound(v, 2) To UBound(v, 2)
If IsNumeric(v(i, j)) And v(i, j) > 1 Then
v(i, j) = 1 ' Cap value to 1.
End If
Next j
Next i
r = v ' Write Variant array back to sheet.
What is the harm in looping? I just tested this code on a range of 39900 cells and it ran in 2 Secs.
Sub Sample()
Dim Rng As Range, aCell As Range
Set Rng = Cells.SpecialCells(xlCellTypeConstants, xlNumbers)
For Each aCell In Rng
If aCell.Value > 1 Then aCell.Value = 1
Next aCell
End Sub
My only concern is the use of SpecialCells as they are unpredictable and hence I rarely use them.
Also have a look at this KB article: http://support.microsoft.com/?kbid=832293