I found this code on the internet. How do I get the sum value to appear in the empty cell above the cells containing consecutive values. I'm thinking of running the code from the last row. Thank for all
https://www.extendoffice.com/documents/excel/3963-excel-sum-until-blank.html
Sub InsertTotals()
'Updateby Extendoffice
Dim xRg As Range
Dim i, j, StartRow, StartCol As Integer
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.AddressLocal
Set xRg = Application.InputBox("please select the cells:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
StartRow = xRg.Row
StartCol = xRg.Column
For i = StartCol To xRg.Columns.Count + StartCol - 1
For j = xRg.Row To xRg.Rows.Count + StartRow - 1
If Cells(j, i) = "" Then
Cells(j, i).Formula = "=SUM(" & Cells(StartRow, i).Address & ":" & Cells(j - 1, i).Address & ")"
StartRow = j + 1
End If
Next
StartRow = xRg.Row
Next
End Sub
Related
I have a data like this :
A049
A050
A051
A053
A054
A055
A056
A062
A064
A065
A066
And I want the output like :
As you can see, I want the ranges which are in consecutive order
I am trying some thing like this:
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
For i = 2 To lastRow
r = wb.Sheets("Sheet1").Range("A" & i).Value
If wb.Sheets("Sheet1").Range("A" & i).Value = wb.Sheets("Sheet1").Range("A" & i+1).Value
Next i
End Sub
But not helping me
Am feeling charitable so have tried some code which should work. It assumes your starting values are in A1 down and puts results in C1 down.
Sub x()
Dim v1, v2(), i As Long, j As Long
v1 = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
ReDim v2(1 To UBound(v1, 1), 1 To 2)
For i = LBound(v1, 1) To UBound(v1, 1)
j = j + 1
v2(j, 1) = v1(i, 1)
If i <> UBound(v1, 1) Then
Do While Val(Right(v1(i + 1, 1), 3)) = Val(Right(v1(i, 1), 3)) + 1
i = i + 1
If i = UBound(v1, 1) Then
v2(j, 2) = v1(i, 1)
Exit Do
End If
Loop
End If
If v1(i, 1) <> v2(j, 1) Then v2(j, 2) = v1(i, 1)
Next i
Range("C1").Resize(j, 2) = v2
End Sub
Try the below code
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
Dim lastNum, Binsert As Integer
Dim firstCell, lastCell, currentCell As String
Binsert = 1
lastNum = getNum(wb.Sheets("Sheet1").Range("A1").Value)
firstCell = wb.Sheets("Sheet1").Range("A1").Value
For i = 2 To lastRow
activeNum = getNum(wb.Sheets("Sheet1").Range("A" & i).Value)
currentCell = wb.Sheets("Sheet1").Range("A" & i).Value
If (activeNum - lastNum) = 1 Then
'nothing
Else
lastCell = wb.Sheets("Sheet1").Range("A" & (i - 1)).Value
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> lastCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = lastCell
End If
Binsert = Binsert + 1
firstCell = wb.Sheets("Sheet1").Range("A" & i).Value
End If
lastNum = activeNum
Next i
'last entry
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> currentCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = currentCell
End If
End Sub
Public Function getNum(ByVal num As String) As Integer
getNum = Val(Mid(num, 2))
End Function
Another solution. It loops backwards from last row to first row.
Option Explicit
Public Sub FindConsecutiveValues()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lRow As Long 'find last row
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim lVal As String 'remember last value (stop value)
lVal = ws.Range("A" & lRow).Value
Const fRow As Long = 2 'define first data row
Dim i As Long
For i = lRow To fRow Step -1 'loop from last row to first row backwards
Dim iVal As Long
iVal = Val(Right(ws.Range("A" & i).Value, Len(ws.Range("A" & i).Value) - 1)) 'get value of row i without A so we can calculate
Dim bVal As Long
bVal = 0 'reset value
If i <> fRow Then 'if we are on the first row there is no value before
bVal = Val(Right(ws.Range("A" & i - 1).Value, Len(ws.Range("A" & i - 1).Value) - 1)) 'get value of row i-1 without A
End If
If iVal - 1 = bVal Then
ws.Rows(i).Delete 'delete current row
Else
If lVal <> ws.Range("A" & i).Value Then 'if start and stop value are not the same …
ws.Range("B" & i).Value = lVal 'write stop value in column B
End If
lVal = ws.Range("A" & i - 1).Value 'remember now stop value
End If
Next i
End Sub
I have a sheet with details regarding orders. In column G a specific value indicates what container (shipping container) the order is packed in.screenshot
I would like all duplicate container no. to be highlighted with different colors and their row with them.
Meaning: that when I have "container no. X" the entire row connected to X is one color and rows connected to "container no. Y" is another color and so on.
I would also like an automatic update of colors when something changes or when I hit "update values" in the data bar
Blank cells in column G should not to be colored.
Is this possible and if so, can someone help me out. I am very much a beginner with VBA.
Sub ColorCompanyDuplicates()
'Updateby Extendoffice
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
If xCell.Value <> "" Then
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
End If
Next
End Sub
This code does number 1 and 3.
Also, it only uses bright colors.
Sub ColorCompanyDuplicates()
Dim row_start As Long, last_row As Long, color_index As Long
Dim R As Long, last_col As Long, col As Long
Dim used_range As Range, paint_row As Boolean
'CONFIG -------------------------
row_start = 5 'first row of the data set
paint_row = True 'set to false if you want to paint only the column
'--------------------------------
color_index = 33
Set used_range = ActiveSheet.UsedRange
last_col = _
used_range.Columns.Count + used_range.Column - 1
last_row = _
Cells(Rows.Count, 7).End(xlUp).Row
'clean existing rows in container names
For R = row_start To last_row
If Range("g" & R) <> "" Then
Range("g" & R).Value = Split(Range("g" & R).Value, " ")(0)
End If
Next R
'paint duplicates
For R = row_start To last_row
'if the next container name is the same and is not null then paint
If Cells(R, 7) = Cells(R + 1, 7) And Cells(R, 7) <> "" Then
If paint_row Then
For col = used_range.Column To last_col
Cells(R, col).Interior.ColorIndex = color_index
Next col
Else
For col = used_range.Column To last_col
Cells(R, col).Interior.ColorIndex = 0
Next col
Cells(R, 7).Interior.ColorIndex = color_index
End If
'FOR THE LAST ONE in the group
'if previews container name is the same and is not null then paint
ElseIf Cells(R, 7) = Cells(R - 1, 7) And Cells(R, 7) <> "" Then
If paint_row Then
For col = used_range.Column To last_col
Cells(R, col).Interior.ColorIndex = color_index
Next col
Else
For col = used_range.Column To last_col
Cells(R, col).Interior.ColorIndex = 0
Next col
Cells(R, 7).Interior.ColorIndex = color_index
End If
'and change color for the next group
color_index = color_index + 1
'avoid dark colors
If color_index = 46 Then
color_index = 33
End If
End If
Next R
'add row numbers to containers name
For R = row_start To last_row
If Range("g" & R) <> "" Then
Cells(R, 7) = Cells(R, 7) & " ROW:" & R
End If
Next R
End Sub
I would suggest for number 2 just create a refresh button or a command shortcut.
I have a table which contains merged cells both column and rows as shown in attached picture. I want to unmerge "Only" rows while leaving columns merged. Consider the following snippet of table. In the image attached "Contract
For y = 1 To lRow
p = 1
c = y
d = 1
z = lRow + y
t = Cells(y, 1).Value
For x = 1 To t
Cells(z, p).Value = Cells(c, d).Value
Cells(c, d).Select
' Debug.Print
Selection.End(xlToRight).Select
c = ActiveCell.Row
d = ActiveCell.Column
p = p + 1
Next
Next
Sub ColorMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells And c.MergeArea.Rows.Count >= 2 Then
c.Interior.ColorIndex = 28
With c.MergeArea.Rows
.UnMerge
' .Formula = c.Formula
End With
'
'startcolumn = ActiveCell.Column
'endcolumn = Selection.Columns.Count + startcolumn - 1
'startrow = ActiveCell.Row
'endrow = Selection.Rows.Count + startrow - 1
End If
Next
End Sub
Based on your snapshot of requirements , I have wrote a very simple code which shall appear to be crude but I have kept it this way so that you can adjust its various elements as per your actual data. Sample data taken by me and results obtained are shown in the snapshot pasted below, which is followed by code.
Sub Merge_unmerge()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim LastRow As Long
Dim LastCol As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
With ws
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
Set rng = ws.Range("A1:D" & LastRow)
For Each cell In rng
cell.UnMerge
Next cell
For i = 2 To LastRow
If Range("A" & i) = "" Then
Range("A" & i).Value = Range("A" & i - 1).Value
End If
Next i
For i = 2 To LastRow
If Range("D" & i) = "" Then
Range("D" & i).Value = Range("D" & i - 1).Value
End If
Next i
For i = 1 To LastRow Step 2
Range("B" & i & ":C" & i).Merge
Range("B" & i & ":C" & i).HorizontalAlignment = xlCenter
Next i
End Sub
Never mind. I solved for the issue at hand. Posting if it helps others.
Sub ColorMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells And c.MergeArea.Rows.Count >= 2 Then
c.Interior.ColorIndex = 28
startcolumn = c.Column
endcolumn = c.MergeArea.Columns.Count + startcolumn - 1
startrow = c.Row
endrow = c.MergeArea.Rows.Count + startrow - 1
With c.MergeArea.Rows
.UnMerge
.Formula = c.Formula
End With
For J = startrow To endrow
Application.DisplayAlerts = False
Range(Cells(J, startcolumn), Cells(J, endcolumn)).Merge
Application.DisplayAlerts = True
Next
End If
Next
End Sub
I am creating a summary macro and I need to add up all the values of column C and D into the merged cell in E. In the image attached the sums are already placed to show the result I want. I already have code to merge the cells in column E based on the names in A. IE Sum up all overdue and critical for bob and place in merged column, then nick. Here is what I have I just need help getting the sum:
Sub MergeSameCell()
Dim Rng As Range, xCell As Range
Dim xRows As Integer
Set WorkRng = ThisWorkbook.Worksheets("Summary").Range("A:A")
lastRow = ActiveSheet.Columns("A").Cells.Find("*", SearchOrder:=xlByRows,
LookIn:=xlValues, SearchDirection:=xlPrevious).Row
xRows = lastRow
For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
WorkRng.Parent.Range(Rng.Cells(i, 5), Rng.Cells(j - 1, 5)).Merge
i = j - 1
Next
Next
End Sub
The below uses your enclosed data specifically and assumes the data has already been sorted by column A and the cells in column E are already merged.
Public Sub GroupSum()
Dim i0 As Long, i1 As Long, strName As String
With ActiveSheet
For i0 = 2 To .UsedRange.Rows.Count
If Not .Cells(i0, 1).Value = strName Then
strName = .Cells(i0, 1)
i1 = i0
End If
.Cells(i1, 5).Value = .Cells(i0, 3).Value + .Cells(i0, 4).Value + .Cells(i1, 5).Value
Next i0
End With
End Sub
I will leave the alignment formatting of the merged cells to you.
Option Explicit
Sub MergeSameCell()
Dim clientRng As Range
Dim lastRow As Long, lastClientRow As Long
With ThisWorkbook.Worksheets("Summary")
.Columns(5).UnMerge
Set clientRng = .Range("A2")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Do
lastClientRow = .Columns(1).Find(what:=clientRng.Value, after:=clientRng, _
lookat:=xlWhole, SearchDirection:=xlPrevious).Row
With clientRng.Offset(0, 4)
.Resize(lastClientRow - clientRng.Row + 1, 1).Merge
.Formula = "=sumifs(c:c, a:a, " & Chr(34) & clientRng.Value2 & Chr(34) & ")+" & _
"sumifs(d:d, a:a, " & Chr(34) & clientRng.Value2 & Chr(34) & ")"
'optionally revert the formulas to their returned value
'value = .value2
End With
Set clientRng = clientRng.Offset(lastClientRow - clientRng.Row + 1, 0)
Loop While clientRng.Row <= lastRow
End With
End Sub
This removes a couple of loops:
Sub MergeSameCell()
With ThisWorkbook.Worksheets("Summary")
Dim i as Long
For i = 2 To .Rows.Count
If .Cells(i, 1) = "" Then Exit Sub
Dim x As Long
x = .Evaluate("MATCH(TRUE," & .Cells(i, 1).Address & "<>" & .Range(.Cells(i, 1), .Cells(.Rows.Count, 1)).Address & ",0) - 2 + " & i)
.Cells(i, 5).Value = Application.Sum(.Range(.Cells(i, 3), .Cells(x, 4)))
.Range(.Cells(i, 5), .Cells(x, 5)).Merge
i = x
Next i
End With
End Sub
I am trying to create a code in Excel VBA, to locate the beginning (Cell Address) and the end (Cell Address) of coloured rows in a table. The table is a timeline(Horizontal axis- Dates, Vertical axis - General Text). The coloured rows all do not start in the first column, but start in different columns.
Any help?
How's this?
Sub findColoredRows()
Dim startCol As Integer, endCol As Integer, o As Integer
Dim ws As Worksheet
Dim i As Integer, k As Integer
Dim startRow As Long, endRow As Long
Dim cellColor As String, noColor As String
Dim cel As Range
noColor = -4142 ' this is the color index of NO coloring
k = 3
Set ws = ActiveSheet
With ws
startRow = .Cells(1, 3).End(xlDown).Row
startCol = .Cells(1, 3).Column
Do While startRow > 100 ' I assume your table starts before row 100. So, if there's no data before row 100, check next column
k = k + 1
startRow = .Cells(1, k).End(xlDown).Row
startCol = k
Loop
'Now, we have our starting row - get end row.
endRow = .Cells(startRow, k).End(xlDown).Row
endCol = .Cells(startRow, startCol).End(xlToRight).Column
Debug.Print "Start row: " & startRow & ", start column: " & startCol
' How many non colored cells is there in our range?
Dim noColorCells As Integer
For Each cel In .Range(.Cells(startRow, startCol), .Cells(endRow, endCol))
If cel.Interior.ColorIndex = noColor Then
noColorCells = noColorCells + 1
End If
Next cel
Debug.Print "There are " & noColorCells & " non colored cells."
.Cells(startRow - 1, endCol + 2).Value = "Start Date"
.Cells(startRow - 1, endCol + 3).Value = "End Date"
'reDim the array to fit the colored cells
ReDim tDates(1 To noColorCells + 1)
i = 1 'index starts at 1, so set this to 1
For k = startRow To endRow
For o = startCol To endCol
If .Cells(k, o).Interior.ColorIndex = noColor And .Cells(k, endCol + 2) = "" Then
.Cells(k, endCol + 2).Value = .Cells(k, o).Value
ElseIf .Cells(k, o).Interior.ColorIndex = noColor And .Cells(k, endCol + 2) Then
i = i + i
.Cells(k, endCol + 3).Value = .Cells(k, o).Value
End If
' i = i + 1
Next o
i = i + 1
Next k
End With
MsgBox ("Done!")
End Sub
This sub will find the addresses of any colored cells. If you can explain more what you mean by "locate the beginning and the end of coloured rows in a table." I can tweak this. Can you post an image of a sample table maybe?
Edit: Per discussion below, try this in case there's not always data in the table, but you want the columns of the colored cells:
Sub findColoredBGCells()
Dim startRow As Integer, endRow As Integer, i As Integer, k As Integer, startCol As Integer, endCol As Integer
Dim cellColor As String, noColor As String
Dim ws As Worksheet
Set ws = ActiveSheet
noColor = -4142
With ws
'Get the starting row
startRow = .Cells(1, 1).End(xlDown).Row
endRow = .Cells(startRow, 1).End(xlDown).Row
' Since we know where the names start and end (less ONE for the "Names" part), let's count how many names we have
Dim noNames As Integer
noNames = endRow - startRow
If Not IsEmpty(.Cells(1, 1)) Then ' Get the first used column with data
startCol = 1
ElseIf IsEmpty(.Cells(1, 1)) Then
startCol = .Cells(1, 1).End(xlToRight).Column
End If
endCol = .Cells(1, startCol).End(xlToRight).Column
'Now we have our range, let's use it to loop for blank cells, and add those to an array
Dim coloredCells() As Variant
ReDim coloredCells(1 To noNames, 2)
Dim rng As Range, cel As Range
Set rng = .Range(.Cells(startRow, startCol), .Cells(endRow, endCol))
'rng.Select
'Now, count how many cells are not blank background
Dim cnt As Integer, celRow As Integer, lastCelRow As Integer
i = 1
lastCelRow = 2
For Each cel In rng
cel.Select
celRow = cel.Row
If cel.Row <> lastCelRow Then 'This is so we can change the first dimension in the array
k = k + 1
coloredCells(k, 0) = .Cells(cel.Row, 1).Value
i = 1
' i = i + 1
End If
If cel.Interior.ColorIndex <> noColor Then
cnt = cnt + 1
If i > 2 Then i = 2 'Since it's only two dimensions we need, only go up to '1'
' ReDim Preserve coloredCells(noNames, i) 'resize the array to hold the new column
coloredCells(k, i) = .Cells(1, cel.Column).Value
i = i + 1
End If
lastCelRow = celRow
Next cel
For k = 1 To UBound(coloredCells)
Debug.Print coloredCells(k, 0) & " Start Date: " & coloredCells(k, 1) & ", end date: " & coloredCells(k, 2) & "."
.Cells(2 + k, 2).Value = coloredCells(k, 1)
.Cells(2 + k, 3).Value = coloredCells(k, 2)
Next k
End With
MsgBox ("Done!")
End Sub