I am trying to create some sumifs formulas. The raw data has three columns: one for Batch ID, the second for Dates and the third for Amounts. I have used a helper column to get the month and the year in column O (to match them with the headers in another sheet)
Here's my attempt
Sub Test()
Dim sBatchCol As String, sDates As String, sAmount As String, sDateTarget As String, lr As Long, m As Long, c As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With shPayment
lr = .Cells(Rows.Count, 1).End(xlUp).Row
With .Range("O2:O" & lr)
.Formula = "=""'"" & CHOOSE(MONTH(J2),""Jan"",""Feb"",""Mar"",""Apr"",""May"",""Jun"",""July"",""Aug"",""Sep"",""Oct"",""Nov"",""Dec"")&""-""&YEAR(J2)"
.Value = .Value
End With
sBatchCol = .Range("D2:D" & lr).Address(, , , True)
sDates = .Range("O2:O" & lr).Address(, , , True)
sAmount = .Range("K2:K" & lr).Address(, , , True)
End With
With shMonthlyFunds
m = .Cells(Rows.Count, 1).End(xlUp).Row - 1
For c = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
If .Cells(1, c).Value Like "???-####" Then
sDateTarget = .Cells(1, c).Address
With .Range(.Cells(2, c), .Cells(m, c))
.Formula = "=SUMIFS(" & sAmount & "," & sBatchCol & ",A2," & sDates & "," & sDateTarget & ")"
End With
End If
Next c
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
The code is working but it is quite slow. I tried to turn off the calculation but the same problem is still there.
Related
I have several columns that I need to concatenante, while the text styling for one column is kept intact and each column is concatenated in a new line (carriage return).
Col A text in bold, Col B text normal, Col C = concatenated col A content in bold + carriage return + col B content.
Using Concatenate formula in combination with CHAR(10) works but obviously the text styling isn't kept. VBA seems to be the way to go but I'm a total newbie at it.
I found the following code that does the concatenation, kees the styling but for the life of me I cant figure how to include a carriage return with vbCrLf in a string.
Sub MergeFormatCell()
Dim xSRg As Range
Dim xDRg As Range
Dim xRgEachRow As Range
Dim xRgEach As Range
Dim xRgVal As String
Dim I As Integer
Dim xRgLen As Integer
Dim xSRgRows As Integer
Dim xAddress As String
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xSRg = Application.InputBox("Select cell columns to concatenate:", "Concatenate in Excel", xAddress, , , , , 8)
If xSRg Is Nothing Then Exit Sub
xSRgRows = xSRg.Rows.Count
Set xDRg = Application.InputBox("Select cells to output the result:", "Concatenate in Excel", , , , , , 8)
If xDRg Is Nothing Then Exit Sub
Set xDRg = xDRg(1)
For I = 1 To xSRgRows
xRgLen = 1
With xDRg.Offset(I - 1)
.Value = vbNullString
.ClearFormats
Set xRgEachRow = xSRg(1).Offset(I - 1).Resize(1, xSRg.Columns.Count)
For Each xRgEach In xRgEachRow
.Value = .Value & Trim(xRgEach.Value) & " "
Next
For Each xRgEach In xRgEachRow
xRgVal = xRgEach.Value
With .Characters(xRgLen, Len(Trim(xRgVal))).Font
.Name = xRgEach.Font.Name
.FontStyle = xRgEach.Font.FontStyle
.Size = xRgEach.Font.Size
.Strikethrough = xRgEach.Font.Strikethrough
.Superscript = xRgEach.Font.Superscript
.Subscript = xRgEach.Font.Subscript
.OutlineFont = xRgEach.Font.OutlineFont
.Shadow = xRgEach.Font.Shadow
.Underline = xRgEach.Font.Underline
.ColorIndex = xRgEach.Font.ColorIndex
End With
xRgLen = xRgLen + Len(Trim(xRgVal)) + 1
Next
End With
Next I
End Sub
The interest of the above code is that it allows the user to specify via an input box the cells range to concatenate and where to output the results.
Anyone can give me a hand and modify it so each new column goes in a new line after concatenation?
If you got a simplier solution I'm all for it as long as it works.
p.s. I'm running Excel 2013 if that matters.
This below code does not copy formatting, but it is concatenate both columns and bold the value appears in column A.
Option Explicit
Sub test()
Dim LastRow As Long, Row As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Row = 1 To LastRow
With .Range("C" & Row)
.Value = ThisWorkbook.Worksheets("Sheet1").Range("A" & Row).Value & vbNewLine & ThisWorkbook.Worksheets("Sheet1").Range("B" & Row).Value
.Characters(1, Len(ThisWorkbook.Worksheets("Sheet1").Range("A" & Row).Value)).Font.FontStyle = "Bold"
End With
Next Row
End With
End Sub
EDITED VERSION:
Option Explicit
Sub test()
Dim LastRow As Long, Row As Long
Dim strA As String, strB As String, strC As String, strD As String, strE As String, strF As String
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Row = 1 To LastRow
strA = .Range("A" & Row).Value
strB = .Range("B" & Row).Value
strC = .Range("C" & Row).Value
strD = .Range("D" & Row).Value
strE = .Range("E" & Row).Value
strF = .Range("F" & Row).Value
With .Range("G" & Row)
.Value = strA & vbNewLine & strB & vbNewLine & strC & vbNewLine & strD & vbNewLine & strE & vbNewLine & strF
.Characters(1, Len(strA)).Font.FontStyle = "Bold"
.Characters((Len(strA) + Len(strB) + 5), Len(strC)).Font.FontStyle = "Bold"
.Characters((Len(strA) + Len(strB) + Len(strC) + Len(strD) + 9), Len(strE)).Font.FontStyle = "Bold"
End With
Next Row
End With
End Sub
I am building on some code, partly cut and paste from other posts. I need to concatenate with a VBA code keeping the format and running through rows to output in last cell in each row. (Can't paste image) so hope description is clear:
In A1:D1 values are RED,BLUE,GREEN
In A2:D2 Values are YELLOW,PURPLE,ORANGE
OUTPUT IN E1 should concatenate these values, keeping font colour. Each value should have "ALT ENTR" to give line break.
Next row should be displayed in E2, and so on
'************************************************************************************
Sub test()
Dim rng As Range: Set rng = Application.Range("a1:c1") 'Not yet looping
Dim row As Range
For Each row In rng.Rows
'Debug.Print col.Column
Call concatenate_cells_formats(Cells(1, 4), rng) 'Not yet looping
Next row
End Sub
Sub concatenate_cells_formats(cell As Range, source As Range)
'Anon
Dim c As Range
Dim i As Integer
i = 1
With cell
.Value = vbNullString
.ClearFormats
For Each c In source
.Value = .Value & " " & Trim(c)
Next c
.Value = Trim(.Value)
For Each c In source
With .Characters(Start:=i, Length:=Len(Trim(c))).Font
.Name = c.Font.Name
.FontStyle = c.Font.FontStyle
.Size = c.Font.Size
.Strikethrough = c.Font.Strikethrough
.Superscript = c.Font.Superscript
.Subscript = c.Font.Subscript
.OutlineFont = c.Font.OutlineFont
.Shadow = c.Font.Shadow
.Underline = c.Font.Underline
.ColorIndex = c.Font.ColorIndex
End With
.Characters(Start:=i + Len(c), Length:=1).Font.Size = 1
i = i + Len(Trim(c)) + 1
Next c
End With
End Sub
'*****************************************************************************
Option Explicit
Sub concColour()
Dim i As Long, j As Long, s As Long, l As Long, clr As Long, vals As Variant
With Worksheets("sheet4")
For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
vals = Application.Transpose(Application.Transpose(Intersect(.Range("A:D"), .Rows(i)).Value2))
.Cells(i, "E") = Join(vals, vbLf)
s = 1
For j = LBound(vals) To UBound(vals)
l = Len(vals(j))
clr = .Cells(i, "A").Offset(0, j - 1).Font.Color
With .Cells(i, "E").Characters(Start:=s, Length:=l).Font
.Color = clr
End With
s = s + l + 1
Next j
.Cells(i, "E").Font.Size = 4
Next i
End With
End Sub
enter image description here
I think you require something like this. Change source font and formats as per your requirement.
Sub Adding_T()
Dim lena As Integer
Dim lenc As Integer
Dim lend As Integer
Dim lene As Integer
Dim LastRow As Long
Dim nrow As Long
With Worksheets("Sheet2") 'Change sheet as per your requirement
LastRow = .Cells(.Rows.Count, "A").End(xlUp).row
For nrow = 1 To LastRow
.Range("E" & nrow) = .Range("A" & nrow).Value2 & Chr(13) & Chr(10) & .Range("B" & nrow).Value2 & _
Chr(13) & Chr(10) & .Range("C" & nrow).Value2 & Chr(13) & Chr(10) & .Range("D" & nrow).Value2
lena = Len(.Range("A" & nrow).Value2)
lenc = lena + 2 + Len(.Range("B" & nrow).Value2)
lend = lenc + 2 + Len(.Range("C" & nrow).Value2)
lene = lend + 2 + Len(.Range("D" & nrow).Value2)
For i = 1 To lena
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("A" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
For i = lena + 2 To lenc
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("B" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
For i = lenc + 2 To lend
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("C" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
For i = lend + 2 To lene
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("D" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
Next
End With
End Sub
Snapshot of trial:
EDIT: OP Preferred code does not permit looping through the Range. Amended his Sub Test() to allow looping through the range.
Sub Test2()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = ThisWorkbook.ActiveSheet
Dim rng As Range
Dim row As Range
Dim rw As Long
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).row
rw = 1
For rw = 1 To LastRow
Set rng = ws.Range("A" & rw & ":C" & rw)
Call concatenate_cells_formats(Cells(rw, 4), rng)
Next
End Sub
Results are as per snapshot appended here.
This is a follow on from How do I get all the different unique combinations of 3 columns using VBA in Excel?
It almost what i need, however, my requirements is that it sums the third column which will contain figures instead of yes/no
Sub sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim col As New Collection
Dim Itm
Dim cField As String
Const deLim As String = "#"
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
cField = .Range("A" & i).Value & deLim & _
.Range("B" & i).Value & deLim & _
.Range("C" & i).Value
On Error Resume Next
col.Add cField, CStr(cField)
On Error GoTo 0
Next i
i = 2
.Range("A1:C1").Copy .Range("F1")
.Range("I1").Value = "Count"
For Each Itm In col
.Range("F" & i).Value = Split(Itm, deLim)(0)
.Range("G" & i).Value = Split(Itm, deLim)(1)
.Range("H" & i).Value = Split(Itm, deLim)(2)
For j = 2 To lRow
cField = .Range("A" & j).Value & deLim & _
.Range("B" & j).Value & deLim & _
.Range("C" & j).Value
If Itm = cField Then nCount = nCount + 1
Next
.Range("I" & i).Value = nCount
i = i + 1
nCount = 0
Next Itm
End With
End Sub
This code was originally added by
Siddharth Rout
try this (follows comments)
Option Explicit
Sub Main()
Dim i As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For i = 4 To Range("A" & Rows.Count).End(xlUp).Row '<-- change 4 and "A" to your data actual upleftmost cell row and column
dict(cells(i, 1).Value & "|" & cells(i, 2).Value) = dict(cells(i, 1).Value & "|" & cells(i, 2).Value) + cells(i, 3).Value '<--| change 3 to your actual "column to sum up" index
Next
With Range("G3").Resize(dict.Count) '<-- change "G3" to your actual upleftmost cell to start writing output data from
.Value = Application.Transpose(dict.Keys)
.TextToColumns Destination:=.cells, DataType:=xlDelimited, Other:=True, OtherChar:="|"
.Offset(, 2).Resize(dict.Count).Value = Application.Transpose(dict.Items) '<--| change 2 to your actual column offset where to start writing summed values form
End With
End Sub
Is there a faster way too compare text/data from different columns? It seems to take longer that desired to execute.
Sub StringCom2()
For Each C In Range("M2:M" & Range("M" & Rows.Count).End(xlUp).Row)
For Each L In Range("X2:X" & Range("X" & Rows.Count).End(xlUp).Row)
If C.Cells.Value = "Audio Accessories" And L.Cells.Value = "Headsets" Then
L.Cells.Offset(0, 18).Value = "Headphones"
End If
Next
Next
For Each C In Range("M2:M" & Range("M" & Rows.Count).End(xlUp).Row)
For Each L In Range("X2:X" & Range("X" & Rows.Count).End(xlUp).Row)
If C.Cells.Value = "Headsets & Car Kits" And L.Cells.Value = "Headsets" Then
L.Cells.Offset(0, 18).Value = "Headsets & Car Kits"
End If
Next
Next
End Sub
You could use "Autofilter()" method of "Range" object
like follows (not by my PC so there may be some typos and or range references/offset to adjust...):
Option Explicit
Sub StringCom2()
With Worksheets("Sheet1") '<--| '<-- change "Sheet1" with your actual sheet name
With .Range("M1:X" & .Cells(.Rows.Count, "M").End(xlUp).Row) '<--| reference its range in columns M:X from row 1 to column "M" last non empty cell row
.AutoFilter field:=1, Criteria1:="Headsets" '<--| filter referenced range on its 1st column ("M") with "Headsets"
.AutoFilter field:=12, Criteria1:="Audio Accessories" '<--|filter referenced range again on its 12th column ("X") with "Audio Accessories"
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then .Offset(1, 19).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible) = "Headphones"'<--| write in cells offsetted 19 columns right of the matching ones
.AutoFilter field:=12, Criteria1:="Headsets & Car Kits" '<--|filter referenced range again on its 12th column ("X") with "Headsets & Car Kits"
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then .Offset(1, 19).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible) = "Headsets & Car Kits"'<--| write in cells offsetted 19 columns right of the matching ones
End With
.AutoFilterMode = False '<--| show all rows back
End With
End Sub
Give this a try and let me know if it terminates faster:
Option Explicit
Sub StringCom_SlightlyImproved()
Dim C As Range, L As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
For Each C In ws.Range("M2:M" & ws.Range("M" & ws.Rows.Count).End(xlUp).Row)
For Each L In ws.Range("X2:X" & ws.Range("X" & ws.Rows.Count).End(xlUp).Row)
If C.Value2 = "Headsets" Then
If L.Value2 = "Audio Accessories" Then L.Offset(0, 18).Value2 = "Headphones"
If L.Value2 = "Headsets & Car Kits" Then L.Offset(0, 18).Value2 = "Headsets & Car Kits"
End If
Next L
Next C
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Changes:
declare all variables to avoid Variants which are slower in performance
turn off unnecessary Excel events, calculation, screen-updating for the sub
bring the two loops together to keep the iterations down
code explicitly
Update:
The following solution should be substantially faster as sheet-access has been limited to a bare minimum. Instead, all calculations / comparisons are completed in memory with variables:
Sub StringCom_Improved()
Dim ws As Worksheet
Dim arrResult As Variant
Dim arrHeadset As Variant
Dim arrAccessories As Variant
Dim i As Long, j As Long, maxM As Long, maxX As Long
Set ws = ThisWorkbook.Worksheets(1)
maxM = ws.Range("M" & ws.Rows.Count).End(xlUp).Row
arrHeadset = ws.Range("M2:M" & maxM).Value2
arrResult = ws.Range("AD2:AD" & maxM).Value2 ' column AD is column M with an offset of 18 columns
maxX = ws.Range("X" & ws.Rows.Count).End(xlUp).Row
arrAccessories = ws.Range("X2:X" & maxX).Value2
For i = LBound(arrHeadset) To UBound(arrHeadset)
For j = LBound(arrAccessories) To UBound(arrAccessories)
If arrHeadset(i, 1) = "Headsets" Then
If arrAccessories(j, 1) = "Audio Accessories" Then arrResult(i, 1) = "Headphones"
If arrAccessories(j, 1) = "Headsets & Car Kits" Then arrResult(i, 1) = "Headsets & Car Kits"
End If
Next j
Next i
ws.Range("AD2:AD" & maxM).Value2 = arrResult
End Sub
The faster way is to use Excel formulas
Sub StringCom2()
m = Range("M" & Rows.Count).End(xlUp).Row
x = Range("X" & Rows.Count).End(xlUp).Row
Set r = Range("X2:X" & x).Offset(, 18)
r.Formula = "= If( CountIf( M2:M" & m & " , ""Headsets"" ) , " & _
" If( X2 = ""Audio Accessories"" , ""Headphones"", " & _
" If( X2 = ""Headsets & Car Kits"" , X2 , """" ) , """" ) , """" ) "
r.Value2 = r.Value2 ' optional to replace the formulas with the values
End Sub
I have written a macro to delete the row if it is a blank row or if in column B the cell contains the string XYZ. However, this macro can take a couple minutes to run if there is 200+ rows of data. Can anyone provide anything more efficient in VBA format?
Sub DeleteBlanks()
Dim lr As Long, r As Long
For r = Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
Range("B" & r).Replace "*XYZ*", "", xlWhole
If Range("B" & r).Value = "" Then
Range("B" & r & ":Q" & r).Delete (xlShiftUp)
End If
Next r
Application.ScreenUpdating = False
End Sub
I would add the ScreenUpdating line to the top, and also turn calculation to manual:
Sub DeleteBlanks()
Dim lr As Long, r As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For r = Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
Range("B" & r).Replace "*XYZ*", "", xlWhole
If Range("B" & r).Value = "" Then
Range("B" & r & ":Q" & r).Delete (xlShiftUp)
End If
Next r
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
As you have it, the entire macro runs, then the screenUpdating is turned off. You can speed it up by putting that up front, then turning it back on when the macro is finished.
In addition to what #BruceWayne said, I will shorten the code
Range("B" & r).Replace "*XYZ*", "", xlWhole
If Range("B" & r).Value = "" Then
With
If Range("B" & r).Value = "" Or InStr(1, Range("B" & r).Value, "XYZ") > 0 then
That will lower the actions that the code needs to make.
First of all, the screen updating should be disabled before the proccess, and re-enabled after that, so the screen will not flash, and load of resources will not be high.
Other than that, text replacement is completely unneeded in your case.
By reading your current code, I assume you consider a blank row if it's empty on column B.
Try this:
Sub DeleteBlanks()
Application.ScreenUpdating = False
Dim lr As Long, r As Long
For r = Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
If Range("B" & r).Value = "" Or Range("B" & r).Value Like "*XYZ*" Then
Range("B" & r & ":Q" & r).Delete (xlShiftUp)
End If
Next r
Application.ScreenUpdating = True
End Sub
This solution should be virtually instantaneous:
Public Sub Colin_H()
Dim v, rCrit As Range, rData As Range
With [a1]
Set rData = .Resize(.Item(.Parent.Rows.Count).End(xlUp).Row, .Item(, .Parent.Columns.Count).End(xlToLeft).Column)
End With
Set rCrit = rData.Resize(2, 2).Offset(, rData.Columns.Count + 1)
rCrit.Resize(1) = rData(1, 2): rCrit(2, 1) = "*": rCrit(2, 2) = "<>*xyz*"
rData.AdvancedFilter xlFilterCopy, rCrit, rCrit.Resize(1, 1).Offset(, 2)
With rCrit.Resize(1, 1).Offset(, 2).Resize(rData.Rows.Count, rData.Columns.Count)
v = .Value2
rData = v
.ClearContents
rCrit.ClearContents
End With
End Sub
Notice that there is no looping, no row shifting, and no iterated range construction.
This uses the advanced filter of the range object to filter your records in one quick blast to a range adjacent to your source data. The result is then copied over the source without using the clipboard. There is no quicker or more efficient way to achieve your objective.