I am trying to merge the cells in a column (column B) based on a condition in another column (Column C).
In Column C, I have a list that starts at 1 and goes to a maximum of 10. However, it may stop at any number before 10 and restart. For Example:
B C
1
2
3
4
5
6
1
2
3
4
1
2
3
4
5
1
As you can see, at B7 and B11, Column C starts over a 1. When this happens, I would like to merge everything above that restart (from 1 to last number before restart). So for this example, I would like to merge B1:B6, B7:10, and B11:15.
This short loop using the WorksheetFunction object MATCH function to locate 'ones' should suffice.
Dim srw As Long, frw As Variant
With Worksheets("Sheet1")
With Intersect(.Columns(3), .UsedRange)
srw = 0
Do While srw < .Rows.Count
frw = Application.Match(1, .Columns(1).Offset(srw + 1, 0), 0)
If Not IsError(frw) Then
.Cells(srw + 1, 1).Resize(frw, 1).Offset(0, -1).Merge
srw = srw + frw
Else
srw = .Cells(Rows.Count, 1).End(xlUp).Row
End If
Loop
End With
End With
It's just a matter of finding the restarting point (the 'ones') and using a little maths to resize the cells to be merged.
an alternative code pattern, using a formula approach with a helper column (cleared before ending) by which jumping through relevant rows only
Option Explicit
Sub test()
Dim i As Long
With Worksheets("Sheet001")
With .Columns(3).SpecialCells(xlCellTypeConstants, xlNumbers)
With .Offset(, 1)
.FormulaR1C1 = "=if(RC[-1]=1,"""",1)"
.Value = .Value
With .SpecialCells(xlCellTypeBlanks)
For i = 1 To .Areas.Count - 1
Range(.Areas(i).Cells(.Areas(i).Count), .Areas(i + 1).Cells(1).Offset(-1)).Offset(0, -2).Merge
Next i
End With
.ClearContents
End With
End With
End With
End Sub
Related
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 currently have a sheet with values that look like this, as an example:
1 A B C D..............
2 1 Title of item 1
3 Formulas and formatting 1
4 2 Title of item 2
5 Formulas and formatting 2
6 3 Title of item 3
7 Formulas and formatting 3
What i want to happen is that the code looks up column A. If column A contains a number > 1 then it inserts that number (-1) rows, but 2 rows down. I then need it fill the formulas (the formulas need to be dragged down) and formats down from the row above to the last row inserted for that section. So it would look something like this:
1 A B C D...............
2 1 Title of item 1
3 Formulas and formatting 1
4 2 Title of item 2
5 Formulas and formatting 2
6 Formulas and formatting 2
7 3 Title of item 3
8 Formulas and formatting 3
9 Formulas and formatting 3
10 Formulas and formatting 3
And so on and so.... Note, it needs to drag the entire row formulas and foramts, not just A-D...
I think I am almost there with the following code, but I can't get it to fill down from the first row with formulas, under the value in A, until the last row inserted for that section....
Here's my code:
Sub Add_Rows()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Cells(r, "A").Value > 1 Then Rows(r + 2).Resize(Cells(r, "A").Value - 1).Insert
Next r
Application.ScreenUpdating = True
End Sub
If any one could help me with the above that would be amazing!! Equally, I think my method might be a bit clumsy, so I am open to more eloquent solutions too!! Thanks Guys, this forum has saved my skin so many times!!! One day I hope I will get to a point where I can maybe answer some questions instead of always asking them!
Try this. You're not actually copying and pasting anything.
Sub Add_Rows()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If IsNumeric(Cells(r, "A")) Then
If Cells(r, "A").Value > 1 Then
Rows(r + 2).Resize(Cells(r, "A").Value - 1).Insert shift:=xlDown
Rows(r + 1).Copy
Rows(r + 2).Resize(Cells(r, "A").Value - 1).PasteSpecial xlPasteAll
End If
End If
Next r
Application.ScreenUpdating = True
Application.CutCopyMode = False
Application.Goto Range("A1")
End Sub
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
I have a shared excel sheet with records being entered all the time. I want to find the last consecutive entry of a specific Name(its 'A' in this example) and record the value at the begining and ending of last occurance.
The output of the attached excel should be
A,2,34 ---when i open when there were 5 entries
A,5,null ---when i opened when there were 9 entries
A,9,6 ---when i opened when there were 11 entries
A,9,3 ---when i opened when there were 12 entries
please help me with the formula that i can use in a different tab of same excel.
Thanks
this should work.
in column C use this formula. Works from row2 and down. row1 should be irrelevant (no consecutive entries at this point).
=IF(B1=B2,B2&","&A1&","&A2,"")
You can also have a formula display whatever is the last entry for that value. This is for value "A".
=LOOKUP(2,1/(B:B=E1),C:C)
A UDF should be able to handle the relative loop.
Option Explicit
Function LastConColVals(rng As Range, crit As String, _
Optional delim As String = ",")
Dim tmp As Variant, r As Long, rr As Long
'allow full column references
Set rng = Intersect(rng, rng.Parent.UsedRange)
With rng
tmp = Array(crit, vbNullString, vbNullString)
For r = .Rows.Count To 1 Step -1
If .Cells(r, 2).Value = crit Then
tmp(2) = .Cells(r, 1).Value
For rr = r To 1 Step -1
If .Cells(rr, 2).Value = crit Then
tmp(1) = .Cells(rr, 1).Value
Else
Exit For
End If
Next rr
'option 1 - null last value for singles
If rr = (r - 1) Then tmp(2) = "null"
'option 2 - truncate off last value for singles
'If rr = (r - 1) Then ReDim Preserve tmp(UBound(tmp) - 1)
Exit For
End If
Next r
End With
LastConColVals = Join(tmp, delim)
End Function
Firstly the Data.
A B
Type 15 5
Type 2 7
Type 3 9
I need to create a loop, that starts at B1 and inserts a number of rows based on the cell value of B.
I found the below code , but it does not loop, and i need the next cell it checks to be the result of the first cell(5) + 1 in order for it to be correct.
**
Result should be :
**
A B
Type 1 5
Type 2 7
Type 3 9
etc.
Thanks in advance !
I messed up the question in the first place, however i have found the answer.
Please see below.
Sub InsertRowsIf()
Dim lr As Long, R As Range, i As Long
lr = Range("B" & Rows.Count).End(xlUp).Row
Set R = Range("B1", "B" & lr)
Application.ScreenUpdating = False
For i = R.Rows.Count To 1 Step -1
If IsNumeric(R.Cells(i, 1).Value) And Not IsEmpty(R.Cells(i, 1)) Then
R.Cells(i, 1).Offset(1, 0).Resize(R.Cells(i, 1).Value).EntireRow.Insert
End If
Next i
Application.ScreenUpdating = True
End Sub