I have a table like the one below. How can I get Excel to put borders around groups with the same number in the 4th column so that there is a border around the groups. I was thinking conditional formatting could do it but I can't think how. So I think the only option is a macro. Could anybody help?
1 64436 549419 1
2 64437 549420 1
3 64438 549421 1
4 64439 549422 1
5 64440 549423 1
6 64441 549424 1
7 64442 549425 1
8 64443 549426 1
9 64444 549427 1
10 64445 549428 1
11 64446 549429 1
12 64447 549430 1
13 64448 549431 2
14 64449 549432 2
15 64450 549433 2
16 64451 549434 2
17 64452 549435 2
18 64453 549436 2
19 64454 549437 2
20 64455 549438 2
21 64456 549439 2
22 64457 549440 4
23 64458 549441 4
24 64459 549442 5
25 64460 549443 5
26 64461 549444 5
27 64462 549445 5
28 64463 549446 5
29 64464 549447 5
30 64465 549448 6
31 64466 549449 6
32 64467 549450 6
33 64468 549451 6
34 64469 549452 6
35 64470 549453 6
36 64471 549454 6
37 64472 549455 9
38 64473 549456 9
39 64474 549457 9
You need to use relative referencing.
Select the column range you want to do the conditional formatting on.
Enter the following three formulas in their own conditions:
=AND($C2=$C3,$C3=$C4)
This one is for the middle items. (Borders on both sides)
=AND($C2<>$C3,$C3=$C4)
This one is for the first in the group. (Border on left, top, right)
=AND($C2=$C3,$C3<>$C4)
This one is for the last in the group. (Border on left, bottom, right)
Format them as you want.
Replace all '$C' with '${Your Column}'. Note that this will not place any borders around single items since you can have no more the three conditional formatting conditions in a selection.
I cannot see a simple non-macro solution to exactly what you need but the solution from PowerUser seems okay.
Here is a macro based solution that will put a border around rows that have the same digit in the final column. I will assume your data are in columns A:D.
To use this macro just click any cell within your list and then fire the macro.
As a quick guide:
AddBorders is the main macro that simply loops through all the cells in the final column and works out when a border is appropriate
AddBorder is a short routine that adds the border.
As a bonus, AddBorder selects a random color from Excel's 56 color palette so that each of your borders are different colors to make easier viewing
Sub AddBorders()
Dim startRow As Integer
Dim iRow As Integer
startRow = 1
For iRow = 2 To ActiveCell.CurrentRegion.Rows.Count
If WorksheetFunction.IsNumber(Cells(iRow + 1, 4)) Then
If Cells(iRow, 4) <> Cells(iRow - 1, 4) Then
AddBorder startRow, iRow - 1
startRow = iRow
End If
Else
AddBorder startRow, iRow
End If
Next iRow
End Sub
Sub AddBorder(startRow As Integer, endRow As Integer)
Dim borderRange As Range
Dim randomColor As Integer
randomColor = Int((56 * Rnd) + 1)
Set borderRange = Range("A" & startRow & ":D" & endRow)
borderRange.BorderAround ColorIndex:=randomColor, Weight:=xlThick
End Sub
I came out with this solution, it works strange on my Excel 2010 :/
I cannot test it on 2003, so please let me know if thats fine.
Sub PaintBorder()
Dim iRow As Integer
iRow = 1
Dim strTemp As String
strTemp = Range("D" & iRow).Value
Dim strPrev As String
Dim sectionStart As Integer
sectionStart = 1
Do
strPrev = strTemp
strTemp = Range("D" & iRow).Value
If strPrev <> strTemp Then
ActiveSheet.Range(Cells(sectionStart, 1), Cells(iRow - 1, 4)).BorderAround xlSolid, xlMedium, xlColorIndexAutomatic
sectionStart = iRow
End If
iRow = iRow + 1
Loop Until strTemp = vbNullString
End Sub
Are you just trying to make it more readable to human eyes? If so, I recommend alternating background colors. For example, every time, the number in that 4th column changes, the background color would change from white to blue and vice-versa. I do this all the time:
Make an additional column E. Since your reference column is D, enter:
=MOD(IF(D5<>D4,E4+1,E4),2)
(i.e. if this row's column D is different from the last row's D, then change from either 0 to 1 or 1 to 0)
Hide the column so that the end-user doesn't see it.
Make 2 conditional formulas. The first will change the row color to white if your hidden value is 0. The second will change it to blue if your hidden value is 1.
No macros. No VBA coding. Just 1 hidden column and a few conditional formulas. And the colors should still alternate properly even though your column D is skipping numbers :)
(I use this daily on XL 2003. I hope it works on 2007)
Related
I am attempting to apply grouping to an Excel 2016 spreadsheet so that it can be more easily viewed and interpreted. The data in the spreadsheet is in a format similar to the following:
A B C
1 1 x y
2 1 x z
3 2 y y
4 2 x z
5 2 z x
6 1 x y
Column A already contains the numbers corresponding to the nesting levels I want in my spreadsheet i.e. rows 3, 4 and 5 are "children" of row 2, so should be grouped together accordingly. The highest level reached in this particular spreadsheet is 5. I do not need to have any further interaction between rows in the spreadsheet, such as calculating subtotals. The spreadsheet is approximately 800 lines and a good solution will be used elsewhere, so doing this manually is not an ideal solution.
How can I get the group function in Excel 2016 to recognise Column A as my grouping and apply the outline accordingly?
This VBA script has been updated to include more levels of grouping.
It will do what you have requested, grouping rows to the row above, based on the increment number.
How it works is explained as comments within the script, including what could cause a possible failure.
Just to note it will fail if anything other than a number is in column A and also if it does not meet the criteria specified in the example comments.
Sub GroupRanges()
' Group levels must start at one and increase by one for each group level
' An error is produced if any levels are skipped
' Excel can only handle eight groups, the script will give a message and end if there are more than eight level groups
' Example: 1 1 2 3 3 4 4 5 will work
' Example: 1 1 2 2 2 4 4 5 will fail and produce an error, in this case group level 3 was skipped.
' Example: 1 2 3 4 5 6 7 8 9 Will fail, too many levels (more than 8)
Dim Sht As Worksheet
Dim LastRow As Long
Dim CurRow As Long
Dim StartRng As Integer
Dim EndRng As Integer
Dim GrpLvl As Integer
Dim MaxLvl As Integer
' This can be changed to define a sheet name
Set Sht = ActiveSheet
' find the highest number in the range to set as a group level
MaxLvl = WorksheetFunction.Max(Range("A:A"))
' If the Max level is greater than 8, then end the script as grouping cannot go beyond 8 levels
If MaxLvl >= 9 Then
MsgBox "You have " & MaxLvl & " group levels, Excel can only handle up to eight groups. This script will now end."
Exit Sub ' end the script if above eight groups
End If
'Set the Starting Group Level.
GrpLvl = 2
' find the last used row
LastRow = Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row
' Change the grouping to the cell above the range
Sht.Outline.SummaryRow = xlAbove
' Remove existing groups to prevent unrequired group levels.
' We now need to suppress error massages when trying to remove group levels that may not exist.
On Error Resume Next ' disable error messages
For x = 1 To 10 ' Repeat 10 times
Sht.Rows.Ungroup ' Remove Groups
Next x
On Error GoTo 0 ' Now it is important re-enable error messages
' Start the first loop to go through for each group level
For y = 2 To MaxLvl
'Reset the variables for each group level pass
CurRow = 1
StartRng = 0
EndRng = 0
' Start the inner loop through each row
For Z = 1 To LastRow
' Check value of cell, if value is 1 less than current group level then clear the Start/End Range Values
If Sht.Range("A" & CurRow) = GrpLvl - 1 Then
StartRng = 0
EndRng = 0
End If
' If cell value equals the group level then set Range Values accordingly
If Sht.Range("A" & CurRow) >= GrpLvl Then
' Check if row is the first of the range
If Sht.Range("A" & CurRow - 1) = GrpLvl - 1 Then
StartRng = CurRow
End If
' Check if row is the Last of the range
If Sht.Range("A" & CurRow + 1) <= 1 Then
EndRng = CurRow
End If
' If both range values are greater than 0 then group the range
If StartRng > 0 And EndRng > 0 Then
Sht.Rows(StartRng & ":" & EndRng).Rows.Group
End If
End If
CurRow = CurRow + 1 ' increase for the next row
Next Z ' repeat the inner loop
' Increase to the next group Level
GrpLvl = GrpLvl + 1
Next y ' repeat the first loop
End Sub
I have two documents having some same rows (and some rows are different). In Document1 I work with file and color some rows (or cells).
How could I switch to Documnent2 and color the rows (cells) I colored in Document1 in the same way? Is there any parser available?
For example:
Doc1:
1 a 1 2 3 4 # is full colored
2 b 1 3 6 7
3 c 1 1 1 2 # is full colored
Doc2:
1 c 1 1 1 2
2 a 1 2 3 4
3 d 5 6 8 1
4 b 1 3 6 7
I need to color rows with indexes 1 and 2, because they are the same as in Doc1, and are full colored.
If I use Format Painter, I get first and third rows colored, but it's wrong for me.
I see the solution like formula, that checks by row letter, is it colored, or not, and colors the row letter in other document. But I don't know how to code it :(
P.S. I also have troubles with getting cell colours - GET.CELL(63,INDIRECT("rc",FALSE)) doesn't work for me, there is no GET.CELL() function found.
P.P.S. Both documents are too big (more than 1.000.000 rows), so I think the best solution would be formula (macroses often are too slow).
The speed of the code depends on how many cells are coloured
You'd have to adapt it to fit your needs
Option Explicit
' Credits: https://stackoverflow.com/a/30067221/1521579
' Credits: https://www.mrexcel.com/board/threads/vba-to-compare-rows-in-two-different-sheets-and-if-they-match-highlight-in-red.1067232/
Sub CheckRows()
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
Dim targetFile As Workbook
Set targetFile = ThisWorkbook 'Workbooks("File2")
Dim targetSheet
Set targetSheet = targetFile.Worksheets("Sheet2")
Dim sourceLastRow As Long
sourceLastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
Dim sourceRange As Range
Set sourceRange = sourceSheet.Range("A1:E" & sourceLastRow)
Dim targetLastRow As Long
targetLastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
Dim targetRange As Range
Set targetRange = targetSheet.Range("A1:E" & targetLastRow)
Dim tempDict As Object
Set tempDict = CreateObject("scripting.dictionary")
Dim cellsString As String
' Add first range to dict
Dim sourceCell As Range
Dim sourceCounter As Long
For Each sourceCell In sourceRange.Columns(1).Cells
sourceCounter = sourceCounter + 1
' Check if cell has color
If sourceCell.Interior.Color <> 16777215 Then
cellsString = Join(Application.Index(sourceCell.Resize(, sourceRange.Columns.Count).Value, 1, 0), "|")
tempDict.item(cellsString) = sourceCell.Interior.Color
End If
Next sourceCell
' Check in target range
Dim targetCell As Range
Dim sourceColor As String
For Each targetCell In targetRange.Columns(1).Cells
cellsString = Join(Application.Index(targetCell.Resize(, targetRange.Columns.Count).Value, 1, 0), "|")
If tempDict.exists(cellsString) Then
sourceColor = tempDict.item(cellsString)
targetCell.Resize(, targetRange.Columns.Count).Interior.Color = sourceColor
End If
Next targetCell
SecondsElapsed = Round(Timer - StartTime, 2)
Debug.Print SecondsElapsed, "Source rows:" & sourceLastRow, "Target rows: " & targetLastRow
End Sub
' Credits: https://stackoverflow.com/a/9029155/1521579
Function GetKey(Dic As Object, strItem As String) As String
Dim key As Variant
For Each key In Dic.Keys
If Dic.item(key) = strItem Then
GetKey = CStr(key)
Exit Function
End If
Next
End Function
If you're comfortable with adding few helper columns in both of your documents, you can use the following solution.
Note that the below solution demonstrates the data being in 2 sheets
within the same document. You can easily apply the same logic with
different documents.
Assumptions:
Number of columns remain the same in both documents
you're looking for an exact match
Solution:
You can download the sample excel document with the below solution from the following link.
Create a helper column(G) in both the documents which is a concatenation of all the existing columns using =TEXTJOIN(", ",FALSE,B2:E2) like below:
A B C D E F -----G-------
1 a 1 2 3 4 a, 1, 2, 3, 4
2 b 1 3 6 7 b, 1, 3, 6, 7
3 c 1 1 1 2 c, 1, 1, 1, 2
In document2 create another column(H) which will identify the corresponding row number from document1 using =IFERROR(MATCH(G2,'document 1'!$G$1:$G$5,0),0) formula. Like below
Note: 0 if no match is found
Add a formula in any cell which will calculate the total number of rows that should be checked in document2
A B C D E F -------G----- H
1 c 1 1 1 2 c, 1, 1, 1, 2 3
2 a 1 2 3 4 a, 1, 2, 3, 4 1
3 d 5 6 8 1 d, 5, 6, 8, 1 0
4 b 1 3 6 7 b, 1, 3, 6, 7 2
5
6 =COUNTA(G1:G4)
Once these columns are added, you can use these columns to loop through the rows in document2 and see if there is match in document1 and copy formatting if there is a match using the code below:
Public Sub Copy_Formatting()
'Stack Overflow question: https://stackoverflow.com/questions/65194893/excel-transfer-color-filling-from-one-document-to-another
Dim Curr_Range As Range, Match_Value As Integer, Rows_to_loop As Integer
Rows_to_loop = Sheet2.Range("G6").Value
For i = 1 To Rows_to_loop
Set Curr_Range = Sheet2.Range("B1:E1").Offset(i, 0)
Match_Value = Sheet2.Range("H1").Offset(i).Value
If Match_Value > 0 Then
Sheet1.Range("B1:E1").Offset(Match_Value - 1).Copy
With Curr_Range.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Curr_Range.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next i
End Sub
Checkout the following GIF that shows the result:
two options:
Use the format painter (mark the cells for which you want to copy formatting, click the format painter icon, switch to Document 2, select the cells where you want to paste formatting)
Use "paste formatting" using Ctrl-C -> go to Document 2 -> Paste Special -> Formats.
If I understand your question correctly: you want to copy only the formatting from excel file 2 to excel file 1 while retaining the information.
copy everything from file 2.
paste it in file 1 and press ctrl. Pick the bottom-left option to only retain formatting.
If you're using conditional formatting you can also just make a backup of file 2 and paste file 1 into file 2 while only retaining text (one of the ctrl paste options).
I have two excel sheets, one cumulative (year-to-date) and one periodic (quarterly). I am trying to check for potential entry errors.
Simplified ytd table:
ID Q1/18 Q2/18 Q3/18 Q4/18 Q1/19 Q2/19 ...
1 6 12 20 28 10 20
2 5 11 18 26 10 20
3 5 11 18 26 10 20
Simplified quarterly table:
ID Q1/18 Q2/18 Q3/18 Q4/18 Q1/19 Q2/19 ...
1 6 6 8 8 10 10
2 5 6 7 8 10 10
3 5 6 7 8 10 10
In the above example there are no entry errors.
I am trying to create a third sheet that would look something like this
ID Q1/18 Q2/18 Q3/18 Q4/18 Q1/19 Q2/19 ...
1 T T T T T
2 T T T T T
3 T T T T T
I initially tried using a formula like this:
=IF('YTD'!C2-'YTD LC'!B2-'QTR'!B2=0,T,F)
I don't particularly like this because the formula will not apply in the first quarter. This also assumes that my data in both sheets are ordered in the same way. Whilst I believe it to be true in all cases, I would rather have something like an index-match to confirm.
I tried working on a VBA solution based on other solutions I found here but made less progress than via the formulas:
Sub Compare()
lrow = Cells (Rows.Count, 1).End(xlUp).Row
lcol = Cells(1, Columns.Count).End(xltoLeft).Column
Sheets.Add
ActiveSheet.Name = "Temp Sheet"
For i = 2 To lrow
For j = 3 To lcol
valytd = Worksheets("YTD").Cells(i,j).Value
valytd = Worksheets("YTD").Cells(i,j).Value
If valytd = valytd Then
Worksheets("Temp").Cells(i,j).Value = "T"
Else:
Worksheets("Temp").Cells(i,j).Value = "F"
Worksheets("Temp").Cells(i,j).Interior.Color Index = 40
End If
Next j
Next i
End Sub
In my opinion the easiest way is to:
Create a sheet & copy paste row 1 + Column 1 like image below (Title & IDs)
Use Sum Product to get your answers
Formula:
=IF(SUMPRODUCT((Sheet1!$B$1:$G$1=Sheet3!$B$1)*(Sheet1!$A$2:$A$4=Sheet3!A2)*(Sheet1!$B$2:$G$4))=SUMPRODUCT((Sheet2!$B$1:$G$1=Sheet3!$B$1)*(Sheet2!$A$2:$A$4=Sheet3!A2)*(Sheet2!$B$2:$G$4)),"T","F")
Formula Notes:
Keep fix the range with Quarters using double $$ -> Sheet1!$B$1:$G$1
keep fix the range with IDs using double $$ -> Sheet1!$A$2:$A$4
Keep fix the range with values -> Sheet1!$B$2:$G$
Keep fix column header -> =Sheet3!$B$1
Leave variable rows number -> =Sheet3!A2
Images:
This should do the trick, the code is all commented:
Option Explicit
Sub Compare()
Dim arrYTD As Variant, arrQuarterly As Variant, arrResult As Variant
Dim Compare As Scripting.Dictionary 'You need Microsoft Scripting Runtime for this to work
Dim i As Long, j As Integer, x As Integer
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
.ScreenUpdating = False
End With
With ThisWorkbook
arrYTD = .Sheets("Name of YTD sheet").UsedRange.Value 'this will get everything on that sheet
arrQuarterly = .Sheets("Name of Quarterly sheet").UsedRange.Value 'this will get everything on that sheet
End With
ReDim arrResult(1 To UBound(arrYTD), 1 To UBound(arrYTD, 2)) 'resize the final array with the same size of YTD
Set Compare = New Scripting.Dictionary
'Here we fill the dictionary with the ID's position on the arrQuarterly array
For i = 2 To UBound(arrQuarterly) '2 because 1 is headers
If Not Compare.Exists(arrQuarterly(i, 1)) Then 'this is an error handle if you have duplicated ID's
Compare.Add arrQuarterly(i, 1), i 'now we know the position of that ID on the table
Else
'Your handle if there was a duplicated ID
End If
Next i
'Let's fill the headers on the result array
For i = 1 To UBound(arrYTD, 2)
arrResult(1, i) = arrYTD(1, i)
Next i
'Now let's compare both tables assuming the columns are the same on both tables (same position)
For i = 1 To UBound(arrYTD)
arrResult(i, 1) = arrYTD(i, 1) 'This is the ID
For j = 2 To UBound(arrYTD, 2)
x = Compare(arrYTD(i, 1)) 'this way we get the position on the quarterly array for that ID
If arrYTD(i, j) = arrQuarterly(x, j) Then 'compare if they have the same value on both sides
arrResult(i, j) = "T"
Else
arrResult(i, j) = "F"
End If
Next j
Next i
With ThisWorkbook.Sheets("Name of the result sheet") 'paste the array to it's sheet
.Range("A1", .Cells(UBound(arrResult), UBound(arrResult, 2))).Value = arrResult
End With
End Sub
Being beginner and first time on this site, I truly appreciate your help.
WK 1 WK 2 WK 3 WK 4 WK 5 TOTAL HOURS TOTAL OF FIRST 3 WEEKS <> 0
John 10 0 5 6 5 26 21
Smith 4 1 10 3 4 22 15
Peter 0 4 4 4 2 14 12
Susan 5 5 0 5 8 23 15
From my table I want to add only the first three columns that contain no zero. If there's zero on first three, check on next column and add it up to complete three columns again with no zero value. Some function like in Col H TOTAL OF FIRST 3 WEEKS <>0 (where I had to do it manually).
If I can learn set of VB code or any example with formula or macros, thank you so so much. I'm using Excel 2007.
This is the complicated formula Ali M refers to. It's an array formula entered with ctrl-shift-enter:
=IF(COUNTIF(A2:F2,"<>0")=0,0,SUM(A2:INDEX(A2:F2,SMALL(IF(A2:F2<>0,COLUMN(A2:F2),""),MIN(3,COUNTIF(A2:F2,"<>0"))))))
Note that it works if there are less than three non-zero values.
you can use formula but it would be complicated. instead you can use this subroutine that act exactly as you want!
Public Sub y()
Dim i, sum, c As Integer
Dim Rng, Row, cell As Range
Set Rng = Range("B2:F5")
i = 0
For Each Row In Rng.Rows
For Each cell In Row.Cells
If (cell.Value <> 0 And i < 3) Then
sum = sum + cell.Value
i = i + 1
End If
Next cell
Cells(Row.Row, 7).Value = sum
sum = 0
i = 0
Next Row
End Sub
It always put the sum in column H. you can change it by changing this line:
Cells(Row.Row, 7).Value = sum
I need to compare one cell with next and if next is greater more than 3 than first, than to make it's color.
example: 1 2 6 3 2 8
1 compare with 2 = do not do nothing
2 compare with 6 = make it's color
6 compare with 3 = make it's color to
3 compare with 2 = do not do nothing
2 compare with 8 = make it's color.
Here is code that make cells less then 4 color, but I can't understand how to diff one cell with next :(
Sub Color()
Dim i As Integer
For i = 1 To 7
With ActiveSheet.Cells(i)
If .Value < 4 Then
.Interior.Color = QBColor(10)
End If
End With
Next i
End Sub
Upd:
Oh! Look like I have found solution!
Sub Color()
Dim i As Integer
For i = 1 To 7
With ActiveSheet.Cells(i)
If ActiveSheet.Cells(i) < ActiveSheet.Cells(i + 1) Then
ActiveSheet.Cells(i + 1).Interior.Color = QBColor(10)
End If
End With
Next i
End Sub
You could use conditional formatting for this rather than VBA, Debra covers this topic thoroughly here, http://www.contextures.com/xlcondFormat01.html
In your case:
Select A1:E1
Conditional Formatting ... New Rule (different menu options depending on your Excel version)
Use a formula to determine what cells to format
use =B1-A1>3 to add a relative formula
Pick a fill colour
screenshot from xl2010 below