I have a table in which I want to create a VBA code to write me the dates In ascending order in horizontally method but the problem when I activate the code, it gives me the date with the last criteria. my code is as follows:
Private Sub Worksheet_Activate()
Dim a As Range, ab As Range, b As Range, bc As Range
Set ab = Range("B3:E3")
Set bc = Range("A2:D2")
For Each a In ab
For Each b In bc
If Cells(3, 1) <> "" Then
Cells(3, a.Column) = Range("A3") + Cells(2, b.Column)
Else
Cells(3, a.Column) = ""
End If
Next
Next
End Sub
yes, I changed the Ranges identification names, but the most important part is the solution.
Private Sub Worksheet_Activate()
On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim cng As Range, rng As Range
Set rng = Range("B3:E3")
For Each cng In rng
If Cells(3, 1) <> "" Then
cng.Offset(0, 0).Value = cng.Offset(0, -1) + 1
ElseIf Cells(3, 1) = "" Then
cell.Offset(0, 5).Value = ""
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Related
I would like to merge similar cells by columns, as of now I am using this macro
Sub MergeSimilarCells()
Set myRange = Range("A1:Z300")
CheckAgain:
For Each cell In myRange
If cell.Value = cell.Offset(0, 1).Value And Not IsEmpty(cell) Then
Range(cell, cell.Offset(0, 1)).Merge
cell.VerticalAlignment = xlCenter
cell.HorizontalAlignment = xlCenter
GoTo CheckAgain
End If
Next
End Sub
My problem is with hundreds of rows and 40-50 columns, it takes forever.
I am pretty sure a For Loop could help me there but I am not skilled enough to figure it out
I know the following code is wrong but I am lost
Sub SimilarCells()
Set myRange = Range("A1:G4")
Dim count As Integer
CheckAgain:
count = 1
For Each cell In myRange
If cell.Value = cell.Offset(0, 1).Value And Not IsEmpty(cell) Then
count = count + 1
ElseIf cell.Value <> cell.Offset(0, 1).Value Then
Range(cell, cell.Offset(0, -count)).Merge
End If
Next
End Sub
Here is what I would like to accomplish
Sub MergeMe()
Dim wks As Worksheet: Set wks = Worksheets(1)
Dim myRange As Range: Set myRange = wks.Range("B2:H5")
Dim myCell As Range
Dim myCell2 As Range
Dim firstColumn As Long: firstColumn = myRange.Columns(1).column + 1
Dim lastColumn As Long: lastColumn = firstColumn + myRange.Columns.Count - 1
Dim firstRow As Long: firstRow = myRange.Rows(1).row
Dim lastRow As Long: lastRow = firstRow + myRange.Rows.Count - 1
Dim column As Long
Dim row As Long
OnStart
For column = lastColumn To firstColumn Step -1
For row = lastRow To firstRow Step -1
Set myCell = wks.Cells(row, column)
Set myCell2 = myCell.Offset(0, -1)
If myCell.Value = myCell2.Value Then
With wks.Range(myCell, myCell2)
.Merge
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
End If
Next row
Next column
OnEnd
End Sub
There are quite a few tricks in this code:
we need to get the first and last column and row;
then we should be looping from the last cell (bottom right) to the first one (top left);
we should not enter the first column, because we are using .Offset(0,-1) and we compare every cell with its leftmost one;
the reason for the whole operation, is that by default, the value of a merged cells is kept in its left top cell. The other cells of a merged cell are without a value.
This is why we always compare the merged cells with their "left" neighbour;
These are the OnEnd and OnStart, facilitating the operation.
Public Sub OnEnd()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
Application.StatusBar = False
End Sub
Public Sub OnStart()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
ActiveWindow.View = xlNormalView
End Sub
Only one merge per group
EDITED to fix - thanks Vityata for the heads-up
Sub MergeEm()
Dim rw As Range, i As Long, s As Long, v
Range("C21:J33").Copy Range("C5:J17") 'for testing purposes: replace previous run
Application.ScreenUpdating = False
For Each rw In Range("C5:J17").Rows 'or wherever
i = 1
s = 1
Do While i < (rw.Cells.Count)
v = rw.Cells(i).Value
'check for a run of same values
Do While Len(v) > 0 And v = rw.Cells(i + s).Value
s = s + 1
If i + s > rw.Cells.Count Then Exit Do
Loop
'if s>1 then had a run: merge those ells
If s > 1 Then
Application.DisplayAlerts = False
rw.Cells(i).Resize(1, s).Merge
rw.Cells(i).HorizontalAlignment = xlCenter
Application.DisplayAlerts = True
i = i + s 'skip over the merged range
s = 1 'reset s
Else
i = i + 1
End If
Loop
Next rw
End Sub
I'm pretty sure what bloats your processing time is the goto causing you to loop through everything yet again every time after every merge
Edit to take column A into account and prevent first column cells to merge with cells outside of myRange:
Sub MergeSimilarCells()
Dim i As Long
Dim myCol As String
Set myRange = Range("K1:L30")
myCol = Left(myRange.Address(True, False), InStr(myRange.Offset(0, 1).Address(True, False), "$") - 1)
If Not Intersect(myRange, Range(myCol & ":" & myCol)).Address = myRange.Address Then
Set myRange = Range(Replace(myRange.Address, Left(myRange.Address(True, False), _
InStr(myRange.Address(True, False), "$")), Left(myRange.Offset(0, 1).Address(True, False), _
InStr(myRange.Offset(0, 1).Address(True, False), "$"))))
For i = myRange.Cells.Count To 1 Step -1
If myRange.Item(i).Value = myRange.Item(i).Offset(0, -1).Value And Not IsEmpty(myRange.Item(i)) Then
Range(myRange.Item(i), myRange.Item(i).Offset(0, -1)).Merge
myRange.Item(i).VerticalAlignment = xlCenter
myRange.Item(i).HorizontalAlignment = xlCenter
End If
Next
End If
End Sub
To clarify why myRange has to start in column B: Offset(0, -1) of any cell in column A will cause an error since there is no column to the left of A.
I would like to write a Excel vba to merge cells according to their values and a reference cell in another column. Like the picture attached.
I have over 18000 Lines, with many of variation.
All the values within the line are in order rank.
enter image description here
This is the code that I based my VBA
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("B2:C10")
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
Edit Minor upgrade to allow merged ranges to be extended enabling merge updates.
Merge Vertically Adjacent Cells with Equal Values.
Save in a regular module.
Be sure the constants (Const) come before any other code in the module.
Consider adding a guard to ensure this only runs against the worksheet
it is intended for (see how to after the code).
Run the macro from the Alt-F8 Macro Dialogue.
NB Like most macros, this will wipe the Excel undo buffer.
It cannot be undone with a Ctrl-Z. (The only options are to revert to last saved
or manually edit to the way it was before.)
Copy/Paste
Private Const LastCol = 20
Private Const LastRow = 20
Public Sub Merge_Cells()
Dim r As Range
Dim s As Range
Dim l As Range
Dim c As Long
Dim v As Variant
For c = 1 To LastCol
Set s = Nothing
Set l = Nothing
For Each r In Range(Cells(1, c), Cells(LastRow, c))
v = r.MergeArea(1, 1).Value
If v = vbNullString Then
DoMerge s, l
Set s = Nothing
Set l = Nothing
ElseIf s Is Nothing Then
Set s = r
ElseIf s.Value <> v Then
DoMerge s, l
Set s = r
Set l = Nothing
Else
Set l = r
End If
Next r
DoMerge s, l
Next c
End Sub
Private Sub DoMerge(ByRef s As Range, ByRef l As Range)
If s Is Nothing Then Exit Sub
If l Is Nothing Then Set l = s
Application.DisplayAlerts = False
With Range(s, l)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Merge
End With
Application.DisplayAlerts = True
End Sub
Consider finding the last column and last row programmatically.
If the merge should start after row 1:
For Each r In Range(Cells(1, c), Cells(LastRow, c))
^
Change the 1 to the correct row number or replace with an added const variable.
To guard other worksheets, use the tab name (recommend renaming the tab first):
For Each r In Worksheets(TabName).Range(Cells(1, c), Cells(LastRow, c))
^^^^^^^^^^^^^^^^^^^^
Make this edit to the same line as the starting row edit.
And add Private Const TabName = "The Merge Tabs Name" ' Spaces ok
to the top of the Module with the other Const (constants).
Or place the name directly in the code: Worksheets("The Merge Tabs Name").
Add this into a module, select your range of data (excluding headers), run the macro and see if it works for you.
Public Sub MergeRange()
Dim rngData As Range, lngRow As Long, lngCol As Long, strTopCell As String
Dim strBottomCell As String, strThisValue As String, strNextValue As String
Dim strThisMergeArea As String, strNextMergeArea As String
Set rngData = Selection
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With rngData
For lngCol = 1 To .Columns.Count
strTopCell = ""
For lngRow = 1 To .Rows.Count
If strTopCell = "" Then strTopCell = .Cells(lngRow, lngCol).Address
strThisValue = .Cells(lngRow, lngCol)
strNextValue = .Cells(lngRow + 1, lngCol)
If lngCol > 1 Then
strThisMergeArea = .Cells(lngRow, lngCol - 1).MergeArea.Address
strNextMergeArea = .Cells(lngRow + 1, lngCol - 1).MergeArea.Address
If strThisMergeArea <> strNextMergeArea Then strNextValue = strThisValue & "."
End If
If strNextValue <> strThisValue Or lngRow = .Rows.Count Then
strBottomCell = .Cells(lngRow, lngCol).Address
With rngData.Worksheet.Range(strTopCell & ":" & strBottomCell)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
strTopCell = .Cells(lngRow + 1, lngCol).Address
End If
Next
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There's one trick to this which is able to be changed and that is that it will also group based off the prior column. You can see an example of what I'm talking about in cell C19 ...
... it has worked out that the previous column had a grouping that stopped at that point, therefore, the 1 isn't carried through and grouped to the next lot, it stops and is grouped there. I hope that makes sense and I hope it gives you what you need.
Another thing, this code here will attempt to demerge all of your previously merged data.
Public Sub DeMergeRange()
Dim rngData As Range, lngRow As Long, lngCol As Long, objCell As Range
Dim objMergeArea As Range, strMergeRange As String, strFirstCell As String
Dim strLastCell As String, objDestRange As Range
Set rngData = Selection
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With rngData
For lngCol = 1 To .Columns.Count
For lngRow = 1 To .Rows.Count
Set objCell = .Cells(lngRow, lngCol)
If objCell.Areas(1).MergeArea.Cells.Count > 1 Then
strMergeRange = objCell.Areas(1).MergeArea.Address
objCell.MergeCells = False
strFirstCell = Split(strMergeRange, ":")(0)
strLastCell = Split(strMergeRange, ":")(1)
Set objDestRange = .Worksheet.Range(.Worksheet.Range(strFirstCell).Offset(1, 0).Address & ":" & strLastCell)
.Worksheet.Range(strFirstCell).Copy objDestRange
End If
Next
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
A note, my suggestion is to ensure you have the original source data saved to another workbook/sheet as a backup before running any code over the top of it.
If it stuffs with your data then it will be a right royal pain to undo manually.
The following code checks to see if any of my rows on the main page contain a date from a year ago or older. If it does, it copies it to the "Archive" worksheet and deletes it from the main page. However, what it's doing now is just copying from the main page and overriding what already exists on the archive page instead of adding to the last row. I've tried subbing in LastRow from a function, but I was getting an error with how I was using it. Anyone have a better solution?
Sub TestDateTransfer()
With Application
PrevCalc = .Calculation
.Calculation = xlCalculationManual
.Cursor = xlWait
.Calculate
.EnableEvents = False
.ScreenUpdating = False
End With
Application.DisplayAlerts = False
Worksheets("Archive").Activate
Range("A3:I1000").Select
Selection.ClearContents
Worksheets("Main Page").Activate
Dim MyDate As Date
MyDate = "03/27/2017"
Set i = Sheets("Main Page")
Set E = Sheets("Archive")
Dim d
Dim j
d = 2
j = 2
Do Until IsEmpty(i.Range("C" & j))
If i.Range("C" & j) <= MyDate - 365 Then
d = d + 1
E.rows(d).Value = i.rows(j).Value
End If
j = j + 1
Loop
Worksheets("Archive").Activate
ActiveSheet.Range("H1").Select 'To unselect the page
Worksheets("Main Page").Activate
MyDate = "03/27/2017"
Dim y
Dim z
y = 2
z = 2
Do Until IsEmpty(i.Range("C" & z))
If i.Range("C" & z) <= MyDate - 365 Then
y = y + 1
i.rows(z).Delete
End If
z = z + 1
Loop
With Application
.Cursor = xlDefault
.Calculate
.Calculation = PrevCalc
'.ScreenUpdating = True 'Not Needed...
.EnableEvents = True
End With
ActiveSheet.Range("H1").Select
End Sub
Worksheets("Archive").Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = "hai"
I have written a small piece of code that shows you how to use this. My code is different than yours b/c it loops through the range and checks each cell if the value of the difference between it and NOW is greater than or equal to 1 (which is how to tell if its from lats year or not). Its not how you approach it but it does seem to be more simplified in the approach. Alsoe I soted a bucnh of dates in a spreadsheet and tested this out. just apply to your needs. I hope this helps more?
Private Sub this()
Dim rng As Range
Dim rcell As Range
Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:A20")
For Each rcell In rng.Cells
'note that if you dont put a handler in here to deal with blank cells values this code will run forever. most peop-le do a check with "if rcell.valeu <> vbNullString then etc etc
If DateDiff("yyyy", rcell.Value, Now()) >= 1 Then
Worksheets("Sheet2").Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = rcell.Value
rcell.Value = vbNullString
End If
Next rcell
End Sub
You could exploit AutoFilter() method of Range object and copy/paste filtered rows in one shot:
Option Explicit
Sub main()
Dim MyDate As Date
MyDate = "03/27/2017"
Dim E As Worksheet
Set E = Worksheets("Archive")
With Worksheets("Main Page")
With .Range("C1", .Cells(.Rows.Count, "C").End(xlUp))
.AutoFilter field:=1, Criteria1:="<=" & CDbl((MyDate - 365))
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Intersect(.Parent.UsedRange, .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy Destination:=E.Cells(Rows.Count, 1).End(xlUp).Offset(1)
End With
.AutoFilterMode = False
End With
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
The code below works fine when I manually update column I. What I need is to know if there is a way to still have this code work when I have column I updated by a formula.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("I3:I30"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, -1).ClearContents
Else
With .Offset(0, -1)
.NumberFormat = "m/d/yy h:mm"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub
Worksheet_Change does not fire in responce to a formula update.
See Excel help for Worksheet_Change
Occurs when cells on the worksheet are changed by the user or by an external link.
You could maybe achieve what you want with the Worksheet_Calculate event.
Assuming you want to put a time stamp next to the cells when those vall values change, try this (in addition to your Change event).
Note the use of the Static variable to track previous values, since Calculate event does nopt provide a Target parameter like Change does. This method may not be robust enough since Static's get reset if you break vba execution (eg on an unhandled error). If you want it more robust, consider saving previous values on another (hidden) sheet.
Private Sub Worksheet_Calculate()
Dim rng As Range, cl As Range
Static OldData As Variant
Application.EnableEvents = False
Set rng = Me.Range("I3:I30")
If IsEmpty(OldData) Then
OldData = rng.Value
End If
For Each cl In rng.Cells
If Len(cl) = 0 Then
cl.Offset(0, -1).ClearContents
Else
If cl.Value <> OldData(cl.Row - rng.Row + 1, 1) Then
With cl.Offset(0, -1)
.NumberFormat = "m/d/yy h:mm:ss"
.Value = Now
End With
End If
End If
Next
OldData = rng.Value
Application.EnableEvents = True
End Sub
Update
Tested routine on sample sheet, all works as expected
Sample file contains the same code repeated on 25 sheets, and range to time stamp is 10000 rows long.
To avoid repeating the code, use the Workbook_ events. To minimise run time use variant arrays for the loop.
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Dim rng As Range
Dim NewData As Variant
Dim i As Long
Static OldData As Variant
Application.EnableEvents = False
Set rng = Sh.Range("B2:C10000") ' <-- notice range includes date column
NewData = rng
If IsEmpty(OldData) Then
OldData = rng.Value
End If
For i = LBound(NewData, 1) To UBound(NewData, 1)
If Len(NewData(i, 1)) = 0 And Len(NewData(i, 2)) > 0 Then
rng.Cells(i, 2).ClearContents
Else
If NewData(i, 1) <> OldData(i, 1) Then
With rng.Cells(i, 2)
.NumberFormat = "m/d/yy -- h:mm:ss"
.Value = Now
End With
End If
End If
Next
OldData = rng.Value
Application.EnableEvents = True
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Activate date population on cell change
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Sh.Range("B2:B10000"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 1).ClearContents
Else
'Populate date and time in column c
With .Offset(0, 1)
.NumberFormat = "mm/dd/yyyy -- hh:mm:ss"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub