i am not be able to make this computation efficiently with excel (vba):
Input
Output
Doing this with tables is incredible slow, when you have a few rows and columns is working perfectly, but is no practical when you increase the number of series and rows.
What i do is update Output Table with VBA, steps:
Delete data of Output Listobject Table
Resize Listobject Range with number of dates between (min max Dates1, Dates,2)
Generate Dates and dump it in the Output Listobject Table Dates column.
I get the matching with this formula array formula in each Result row in the output listobject table:
=SUM(IF((DAY(T_1[Date])=DAY([#Date]))*(MONTH(T_1[Date])=MONTH([#Date]))*(YEAR(T_1[Date])=AÑO([#Date]));T_1[Result1]))
The Number of Series is dinamic and rows will be dynamic, i have up to 30 columns and 5000 rows. Could you give me some example or approach to achieve this more efficiently?
Here is a table with time execution speed of participants snippets. Tested with the whole data. 3161 rows x 40 columns (20 Results columns to match):
Execution time table
The following does not list the dates in order, but collects data for each input date. It is similar to the pivot table.
Compare the execution speed with other code.
Sub MergeData()
Dim strU As String
Dim myWs As Worksheet, Ws As Worksheet
Dim vTable() As Variant
Dim vFid1(), vFid2()
Dim k As Integer, n As Integer, c As Integer
Dim sWsName As String, s As String
Dim strSQL As String
Set myWs = Sheets(1) '<~~ Your data Sheet
Set Ws = Sheets(2) '<~~ Result Sheet
sWsName = myWs.Name & "$"
With myWs
c = .Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To c Step 2
n = n + 1
ReDim Preserve vTable(1 To n)
ReDim Preserve vFid1(1 To n)
ReDim Preserve vFid2(1 To n)
vTable(n) = sWsName & .Cells(1, i).Resize(65536, 2).Address(0, 0)
vFid1(n) = "[" & .Cells(1, i) & "]"
vFid2(n) = "[" & .Cells(1, i + 1) & "]"
Next i
End With
For k = 1 To n - 1
s = Replace(vFid2(k), "[", "")
s = Replace(s, "]", "")
strU = strU & "SELECT " & vFid1(k) & " as Dates ," & vFid2(k) & " as Result , '" & s & "' as myPivot " & " FROM [" & vTable(k) & "] where not isnull(" & vFid1(k) & ") union All "
Next k
s = Replace(vFid2(n), "[", "")
s = Replace(s, "]", "")
strU = strU & "SELECT " & vFid1(n) & " as Dates," & vFid2(n) & " as Result, '" & s & "' as myPivot " & " FROM [" & vTable(n) & "] where not isnull(" & vFid1(n) & ") "
strSQL = "TRANSFORM MAX(Result) "
strSQL = strSQL & "SELECT Dates FROM "
strSQL = strSQL & "(" & strU & ") "
strSQL = strSQL & "GROUP BY Dates "
strSQL = strSQL & "ORDER BY Dates "
strSQL = strSQL & "PIVOT myPivot "
exeSQL Ws, strSQL
Ws.Range("a1").CurrentRegion.SpecialCells(xlCellTypeBlanks).Value = 0
End Sub
Sub exeSQL(Ws As Worksheet, strSQL As String)
Dim Rs As Object
Dim strConn As String
Dim i As Integer
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=Excel 12.0;"
Set Rs = CreateObject("ADODB.Recordset")
Rs.Open strSQL, strConn
If Not Rs.EOF Then
With Ws
.Range("a1").CurrentRegion.ClearContents
For i = 0 To Rs.Fields.Count - 1
.Cells(1, i + 1).Value = Rs.Fields(i).Name
Next
.Range("a" & 2).CopyFromRecordset Rs
End With
End If
Rs.Close
Set Rs = Nothing
End Sub
Data image
you can extend over 30 series. This is only 5 series.
Result image
First, I have made the assumption that you have dates and results in adjacent columns in the form of Dates N | Results N, image below.
Second, I have written the below code which should solve your problem. Note: this is not completely scalable as is, but you can use this now to progress further and modify to your needs. Also, please excuse my poor maths to calculate the out_col_num variable.
Option Explicit
Sub Merge_Dates()
'variables to set up dates
Dim lYear As Long: lYear = 2020
Dim lMonth As Long: lMonth = 3
Dim lDay As Long
'arrays
Dim arr_in() As Variant
Dim arr_out() As Variant
Dim x_in As Long, y_in As Long
Dim x_out As Long, y_out As Long
Dim out_col_num As Long, n As Long: n = 1
arr_in = ActiveSheet.UsedRange.Value
'we need to define the bounds for the output array
'this will contain all dates for March (in this example)
'also hold the results in the columns - this is a function on lbound(2)
ReDim arr_out(1 To 32, 1 To (UBound(arr_in, 2) - 1))
'header for out array
arr_out(1, 1) = "Dates"
'load dates
For lDay = 1 To 31
arr_out(lDay + 1, 1) = CDate(Format(DateSerial(lYear, lMonth, lDay), "DD/MM/YYYY"))
Next lDay
'set column headers
For x_out = LBound(arr_out, 2) + 1 To UBound(arr_out, 2)
arr_out(1, x_out) = "Results" & (x_out - 1)
Next x_out
'now loop through in array and map to out array
'you can do this multiple ways, below is just one
'loop x dim in array
For x_in = LBound(arr_in, 2) To UBound(arr_in, 2) Step 2
'loop y dim in array
For y_in = LBound(arr_in, 1) + 1 To UBound(arr_in, 1)
'loop y dim out array to store result
For y_out = LBound(arr_out, 1) + 1 To UBound(arr_out, 1)
If arr_out(y_out, 1) = arr_in(y_in, x_in) Then
'out column is a function of in column
'-n + 3n
out_col_num = (-1 * x_in) + (3 * n)
arr_out(y_out, out_col_num) = arr_in(y_in, x_in + 1)
Exit For
End If
Next y_out
Next y_in
'increment n
n = n + 1
Next x_in
'output
ActiveSheet.Range("A10").Resize(UBound(arr_out, 1), UBound(arr_out, 2)).Value = arr_out
End Sub
So given the example, assuming your dates cover only March 2020 (something you will have to modify to build it more scalable):
Will give the output as below:
I've put something together using ADODB Recordsets, so that I can use .Filter and .Find. This code outputs the unique dates, and then the result on that date for each result set.
Const AD_DATE = 7
Const AD_VARIANT = 12
Const AD_BIGINT = 20
Const AD_VARCHAR = 200
Const AD_FILTERNONE = 0
Sub sResultData()
On Error GoTo E_Handle
Dim aResultSet() As String
Dim lngMaxCol As Long
Dim lngMaxRow As Long
Dim lngLoopRow As Long
Dim lngLoopCol As Long
Dim rsMaster As Object
Dim rsDate As Object
Set rsMaster = CreateObject("ADODB.Recordset")
Set rsDate = CreateObject("ADODB.Recordset")
lngMaxRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
lngMaxCol = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
With rsMaster.Fields
.Append "ResultDate", AD_DATE
.Append "ResultSet", AD_VARCHAR, 50
.Append "ResultData", AD_BIGINT
End With
With rsDate.Fields
.Append "ResultDate", AD_DATE
End With
rsMaster.Open
rsDate.Open
ReDim aResultSet(1 To lngMaxCol / 2)
For lngLoopCol = 2 To lngMaxCol Step 2
aResultSet(lngLoopCol / 2) = ActiveSheet.Cells(1, lngLoopCol)
Next lngLoopCol
For lngLoopRow = 2 To lngMaxRow
For lngLoopCol = 2 To lngMaxCol Step 2
With rsMaster
.AddNew
!ResultDate = ActiveSheet.Cells(lngLoopRow, lngLoopCol - 1)
!ResultSet = ActiveSheet.Cells(1, lngLoopCol)
!ResultData = ActiveSheet.Cells(lngLoopRow, lngLoopCol)
.Update
End With
If (rsDate.BOF And rsDate.EOF) Then ' dealing with first record, so cannot do .Find
rsDate.AddNew
rsDate!ResultDate = ActiveSheet.Cells(lngLoopRow, lngLoopCol - 1)
rsDate.Update
Else
rsDate.MoveFirst
rsDate.Find "ResultDate=" & Format(ActiveSheet.Cells(lngLoopRow, lngLoopCol - 1), "dd/mmm/yyyy")
If (rsDate.EOF) Or (rsDate.EOF) Then
rsDate.AddNew
rsDate!ResultDate = ActiveSheet.Cells(lngLoopRow, lngLoopCol - 1)
rsDate.Update
End If
End If
Next lngLoopCol
Next lngLoopRow
rsDate.Sort = "ResultDate ASC"
rsDate.MoveFirst
rsMaster.Sort = "ResultSet ASC, ResultDate ASC"
For lngLoopCol = 1 To UBound(aResultSet)
lngLoopRow = lngMaxRow + 5
ActiveSheet.Cells(lngLoopRow - 1, lngLoopCol + 1) = aResultSet(lngLoopCol)
rsMaster.Filter = AD_FILTERNONE
rsMaster.Filter = "ResultSet='" & aResultSet(lngLoopCol) & "'"
rsDate.MoveFirst
Do
ActiveSheet.Cells(lngLoopRow, 1) = rsDate!ResultDate
rsMaster.MoveFirst
rsMaster.Find "ResultDate=#" & Format(rsDate!ResultDate, "dd-mmm-yy") & "#"
If Not rsMaster.EOF Then
ActiveSheet.Cells(lngLoopRow, lngLoopCol + 1) = rsMaster!ResultData
End If
lngLoopRow = lngLoopRow + 1
rsDate.MoveNext
Loop Until rsDate.EOF
Next lngLoopCol
sExit:
On Error Resume Next
rsDate.Close
rsMaster.Close
Set rsDate = Nothing
Set rsMaster = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sResultData", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Regards,
Test the next code, please. It will deal with as many (pairs of) columns you will have. It determines the minimum, respectively, maximum used date and iterates between the determined interval, collecting data in arrFin array. You can also use any Date interval. The interval will be automatically determined. My code drops the values one column after the existing range. This is done only for testing reasons. I have to test it in a way... You can drop them wherever you need. So, if you intend to run the code for the second time, you must delete the previously returned values.
Sub testMatchReArrange()
Dim sh As Worksheet, arrD As Variant, DateRng As Range, lastCol As Long, lastRow As Long
Dim i As Long, dateStart As Date, dateFinish As Date, dDiff As Long, arrFin As Variant
Dim boolFound As Boolean, checkDate As Date, j As Long, k As Long, f As Long
Set sh = ActiveSheet 'use here your sheet
lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
lastCol = sh.Cells(1, Columns.count).End(xlToLeft).Column
arrD = sh.Range(sh.Cells(2, 1), Cells(lastRow, lastCol)).value 'array to be processed
'create the specific range keeping only Date, in order to determine the correct date interval. Especially the minimum date...
For i = 1 To lastCol Step 2
If DateRng Is Nothing Then
Set DateRng = sh.Range(sh.Cells(2, i), sh.Cells(lastRow, i))
Else
Set DateRng = Union(DateRng, sh.Range(sh.Cells(2, i), sh.Cells(lastRow, i)))
End If
Next i
dateStart = WorksheetFunction.Min(DateRng) 'starting date
dateFinish = WorksheetFunction.Max(DateRng) 'finishing date
dDiff = dateFinish - dateStart 'the date interval to be processed
'Properly dimension the array to collect the processing result:
ReDim arrFin(1 To dDiff + 2, 1 To lastCol / 2 + 1): f = 1
'Load the head of columns:
arrFin(1, 1) = "Dates"
For i = 2 To lastCol / 2 + 1
arrFin(1, i) = "result" & i - 1
Next i
f = 2 're-initializing the row of for real processed data
checkDate = dateStart 'initialize the date to be used for processing
For i = 1 To dDiff + 1 'for each date in the processed date interval
For j = 1 To UBound(arrD, 1) 'for each row in the processed array
For k = 1 To UBound(arrD, 2) Step 2 'for each column in the processed array (but looking only in add columns)
If CDate(arrD(j, k)) = checkDate Then
arrFin(f, 1) = checkDate: arrFin(f, (k + 1) / 2 + 1) = arrD(j, k + 1)
boolFound = True 'confirming that at least a match exist
End If
Next k
Next j
If Not boolFound Then arrFin(f, 1) = checkDate' Record the date in case of no any match
boolFound = False: f = f + 1
checkDate = checkDate + 1
Next i
'you can use here any other location (sheet, range) to drop the resulted array:
sh.Cells(1, lastCol + 2).Resize(UBound(arrFin, 1), UBound(arrFin, 2)).value = arrFin
End Sub
In case of a big range, it needs some time, but working only in memory (using arrays) it is the maximum possible speed for such a task.
The code below allows you to specify the columns from which to collect the data and outputs the result on a dedicated sheet which would need to be inserted for that purpose. I called it "Output" but you can pick a name that suits you better. Your original data will not be touched.
Sub MergeDataByDate()
' 006
' define the origin of your data
Const FirstDataRow As Long = 2 ' applicable to both data sets
' set the columns to what they are on your sheet (A = 1, B = 2 etc)
Const C1 As Long = 2 ' Date 1 column
Const Cr1 As Long = 3 ' Result 1 column
Const C2 As Long = 8 ' Date 2 column
Const Cr2 As Long = 11 ' Result 2 column
Dim WsOut As Worksheet ' worksheet for output
Dim ArrIn As Variant ' for input
Dim Arr() As Variant ' for output
Dim Dat As Date ' date counter
Dim Rng As Range
Dim i As Long ' Arr index
Dim R As Long ' row counter
Set WsOut = Worksheets("Output") ' the output sheet must exist: rename to suit
With Worksheets("Input") ' use your tab's name
Set Rng = .Range(.Cells(FirstDataRow, 1), _
.Cells(.Rows.Count, C1).End(xlUp) _
.Offset(0, Cr2 - C1))
ArrIn = Rng.Value
ReDim Arr(1 To 3, (2 * UBound(ArrIn)))
For R = 1 To UBound(ArrIn)
Arr(1, i) = ArrIn(R, C1)
Arr(2, i) = ArrIn(R, Cr1)
Arr(1, i + 1) = ArrIn(R, C2)
Arr(3, i + 1) = ArrIn(R, Cr2)
i = i + 2
Next R
End With
Application.ScreenUpdating = False
With WsOut
Set Rng = .Cells(2, 1).Resize(UBound(Arr, 2), UBound(Arr))
Rng.Value = Application.Transpose(Arr)
With .Sort
With .SortFields
.Clear
.Add Key:=Rng.Cells(1), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
End With
.SetRange Rng
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Arr = Rng.Value
For R = (UBound(Arr) - 1) To 1 Step -1
If Arr(R + 1, 1) = Arr(R, 1) Then
Arr(R, 2) = Arr(R, 2) + Arr(R + 1, 2)
Arr(R, 3) = Arr(R, 3) + Arr(R + 1, 3)
For i = 1 To 3
Arr(R + 1, i) = vbNullString
Next i
Else
Arr(R, 2) = Val(Arr(R, 2)) + 0
Arr(R, 3) = Val(Arr(R, 3)) + 0
End If
Next R
Rng.Value = Arr
With WsOut ' sort blanks to the bottom
With .Sort
With .SortFields
.Clear
.Add Key:=Rng.Cells(1), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
End With
.SetRange Rng
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
R = .Cells(.Rows.Count, 1).End(xlUp).Row
Dat = CLng(Cells(R, 1).Value)
For R = R To 3 Step -1
Dat = Dat - 1
Do Until .Cells(R - 1, 1).Value = Dat
.Rows(R).Insert
.Cells(R, 1).Value = Dat
.Cells(R, 2).Value = 0
.Cells(R, 3).Value = 0
Dat = Dat - 1
Loop
Next R
End With
Application.ScreenUpdating = True
End Sub
The code first combines the existing data to a single list, then sorts the list by date. It then unites data from the same days into single lines, deleting the lines that become redundant and sort them to the end of the list where they disappear.
In the last step the remaining data are checked for dates and missing dates are inserted between the last first date in the list and the last. If you are particular about those dates, for example, you want them to be the first and last days of a month it's the most efficient to add those two days with zero results anywhere in the original data. If results for those dates exist the zero values will be discarded. If they don't they, and any intervening days, will be added to the output.
Took me a while, but here is my code:
Sub SubOutput()
'Declarations.
Dim WksInput As Worksheet
Dim WksOutput As Worksheet
Dim RngInputFirstCell As Range
Dim RngOutputFirstCell As Range
Dim BytOffset As Byte
Dim RngRange01 As Range
Dim RngTarget As Range
Dim BytWholeCalendar As Byte
Dim DatFirstDate As Date
Dim DatLastDate As Date
Dim IntCounter01 As Integer
'Setting variables.
Set WksInput = Sheets("Input") 'put here the name of the worksheet with input data
Set WksOutput = Sheets("Output") 'put here the name of the worksheet with the output data
Set RngInputFirstCell = WksInput.Range("A1") 'put here the top left cell of the input data (the one with value Dates1)
Set RngOutputFirstCell = WksOutput.Range("A1") 'put here the top left cell of the output data (the one with value Dates)
'Asking what days are to be reported.
BytWholeCalendar = MsgBox("Do you need the output to report data for every day?", vbYesNoCancel, "Report every day?")
'In case of no answer, the subroutine is terminated.
If BytWholeCalendar <> 6 And BytWholeCalendar <> 7 Then
Exit Sub
End If
'Typing "Dates" in RngOutputFirstCell.
RngOutputFirstCell = "Dates"
'Covering the entire input.
Do Until RngInputFirstCell.Offset(0, BytOffset * 2) = ""
'Setting first part of the range to be copied (dates).
Set RngRange01 = WksInput.Range(RngInputFirstCell.Offset(1, BytOffset * 2), WksInput.Cells(WksInput.Rows.Count, RngInputFirstCell.column + BytOffset * 2).End(xlUp))
'Setting the range where to paste the dates.
Set RngTarget = WksOutput.Cells(WksOutput.Rows.Count, RngOutputFirstCell.column).End(xlUp).Offset(1, 0)
Set RngTarget = RngTarget.Resize(RngRange01.Rows.Count)
'Pasting the dates.
RngTarget.Value = RngRange01.Value
'Copying the result name.
RngOutputFirstCell.Offset(0, BytOffset + 1).Value = RngInputFirstCell.Offset(0, BytOffset * 2 + 1).Value
'Setting BytOffset to cover the next rows of data.
BytOffset = BytOffset + 1
Loop
'Editing the dates according to BytWholeCalendar.
Select Case BytWholeCalendar
Case Is = 6
'Setting variables.
DatFirstDate = Excel.WorksheetFunction.Min(WksOutput.Range(RngOutputFirstCell.Offset(1, 0), RngOutputFirstCell.End(xlDown)))
DatLastDate = Excel.WorksheetFunction.Max(WksOutput.Range(RngOutputFirstCell.Offset(1, 0), RngOutputFirstCell.End(xlDown)))
IntCounter01 = 1
'Clearing dates.
WksOutput.Range(RngOutputFirstCell.Offset(1, 0), RngOutputFirstCell.End(xlDown)).ClearContents
'Filling dates.
For DatFirstDate = DatFirstDate To DatLastDate
RngOutputFirstCell.Offset(IntCounter01, 0).Value = DatFirstDate
IntCounter01 = IntCounter01 + 1
Next DatFirstDate
Case Is = 7
'Sorting output dates.
With WksOutput.Sort
.SortFields.Clear
.SortFields.Add Key:=RngOutputFirstCell, _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
.SetRange Range(RngOutputFirstCell, RngOutputFirstCell.End(xlDown))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Marking unique dates.
Set RngTarget = WksOutput.Range(RngOutputFirstCell.Offset(1, 1), RngOutputFirstCell.End(xlDown).Offset(0, 1))
RngTarget.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],"""",""X"")"
RngTarget.Value = RngTarget.Value
'Sorting output dates by unique values.
With WksOutput.Sort
.SortFields.Clear
.SortFields.Add Key:=RngOutputFirstCell.Offset(0, 1), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
.SetRange Range(RngOutputFirstCell.Offset, RngOutputFirstCell.End(xlDown).Offset(0, 1))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Clearing double dates.
With WksOutput.Range(RngOutputFirstCell.End(xlDown), RngOutputFirstCell.Offset(0, 1).End(xlDown).Offset(1, 0))
.ClearContents
.ClearFormats
End With
End Select
'Setting RngTarget to cover the results' part of the output.
Set RngTarget = WksOutput.Range(RngOutputFirstCell.Offset(1, 1), RngOutputFirstCell.End(xlDown).Offset(0, 1))
Set RngTarget = RngTarget.Resize(, BytOffset)
RngTarget.FormulaR1C1 = "=VLOOKUP(RC" & RngOutputFirstCell.column & ",OFFSET(INDIRECT(""" & WksInput.Name & "!R" & RngInputFirstCell.Row + 1 & "C""" & " & MATCH(R" & RngOutputFirstCell.Row & "C," & WksInput.Name & "!" & WksInput.Range(RngInputFirstCell, RngInputFirstCell.End(xlToRight)).Address(, , xlR1C1) & ",0) + " & RngInputFirstCell.column - 1 & ",FALSE),0,-1,5000,2),2,FALSE)"
'Typing in RngTarget the formula.
'RngTarget.FormulaR1C1 = "=IFERROR(VLOOKUP(RC" & RngOutputFirstCell.column & ",OFFSET(INDIRECT(""" & WksInput.Name & "!R" & RngInputFirstCell.Row + 1 & "C""" & " & MATCH(R" & RngOutputFirstCell.Row & "C," & WksInput.Name & "!" & WksInput.Range(RngInputFirstCell, RngInputFirstCell.End(xlToRight)).Address(, , xlR1C1) & ",0) + " & RngInputFirstCell.column - 1 & ",FALSE),0,-1,5000,2),2,FALSE),0)"
'Transforming formulas into values.
'RngTarget.Value = RngTarget.Value
'Setting RngTarget to select the output data.
Set RngTarget = RngTarget.Offset(0, -1).Resize(, RngTarget.Columns.Count + 1)
'Formatting.
With RngTarget
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
End With
'Setting RngTarget to select the output labels.
Set RngTarget = RngTarget.Offset(-1, 0).Resize(1)
'Formatting.
With RngTarget
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
End With
RngTarget.EntireColumn.AutoFit
Debug.Print "REPORT"; " | "
Debug.Print "WksInput.Parent.Name = WksOutput.Parent.Name ? "; WksInput.Parent.Name = WksInput.Parent.Name; " | "
Debug.Print "WksInput.Name ? "; WksInput.Name; " | "
Debug.Print "RngInputFirstCell.Address ? "; RngInputFirstCell.Address; " | "
Debug.Print "RngInputFirstCell.Value ? "; RngInputFirstCell.Value; " | "
Debug.Print "RngInputFirstCell.Formula ? "; RngInputFirstCell.Formula; " | "
Debug.Print "RngInputFirstCell.Offset(1,0).Address ? "; RngInputFirstCell.Offset(1, 0).Address; " | "
Debug.Print "RngInputFirstCell.Offset(1,0).Value ? "; RngInputFirstCell.Offset(1, 0).Value; " | "
Debug.Print "RngInputFirstCell.Offset(1,0).Formula ? "; RngInputFirstCell.Offset(1, 0).Formula; " | "
Debug.Print "RngInputFirstCell.Offset(0,1).Address ? "; RngInputFirstCell.Offset(0, 1).Address; " | "
Debug.Print "RngInputFirstCell.Offset(0,1).Value ? "; RngInputFirstCell.Offset(0, 1).Value; " | "
Debug.Print "RngInputFirstCell.Offset(0,1).Formula ? "; RngInputFirstCell.Offset(0, 1).Formula; " | "
Debug.Print "RngInputFirstCell.Offset(1,1).Address ? "; RngInputFirstCell.Offset(1, 1).Address; " | "
Debug.Print "RngInputFirstCell.Offset(1,1).Value ? "; RngInputFirstCell.Offset(1, 1).Value; " | "
Debug.Print "RngInputFirstCell.Offset(1,1).Formula ? "; RngInputFirstCell.Offset(1, 1).Formula; " | "
Debug.Print "RngInputFirstCell.Offset(91,0).Address ? "; RngInputFirstCell.Offset(91, 0).Address; " | "
Debug.Print "RngInputFirstCell.Offset(91,0).Value ? "; RngInputFirstCell.Offset(91, 0).Value; " | "
Debug.Print "RngInputFirstCell.Offset(91,0).Formula ? "; RngInputFirstCell.Offset(91, 0).Formula; " | "
Debug.Print "RngInputFirstCell.Offset(91,1).Address ? "; RngInputFirstCell.Offset(91, 1).Address; " | "
Debug.Print "RngInputFirstCell.Offset(91,1).Value ? "; RngInputFirstCell.Offset(91, 1).Value; " | "
Debug.Print "RngInputFirstCell.Offset(91,1).Formula ? "; RngInputFirstCell.Offset(91, 1).Formula; " | "
Debug.Print "WksOutput.Name ? "; WksOutput.Name; " | "
Debug.Print "RngOutputFirstCell.Address ? "; RngOutputFirstCell.Address; " | "
Debug.Print "RngOutputFirstCell.Value ? "; RngOutputFirstCell.Value; " | "
Debug.Print "RngOutputFirstCell.Formula ? "; RngOutputFirstCell.Formula; " | "
Debug.Print "RngOutputFirstCell.Offset(1,0).Address ? "; RngOutputFirstCell.Offset(1, 0).Address; " | "
Debug.Print "RngOutputFirstCell.Offset(1,0).Value ? "; RngOutputFirstCell.Offset(1, 0).Value; " | "
Debug.Print "RngOutputFirstCell.Offset(1,0).Formula ? "; RngOutputFirstCell.Offset(1, 0).Formula; " | "
Debug.Print "RngOutputFirstCell.Offset(0,1).Address ? "; RngOutputFirstCell.Offset(0, 1).Address; " | "
Debug.Print "RngOutputFirstCell.Offset(0,1).Value ? "; RngOutputFirstCell.Offset(0, 1).Value; " | "
Debug.Print "RngOutputFirstCell.Offset(0,1).Formula ? "; RngOutputFirstCell.Offset(0, 1).Formula; " | "
Debug.Print "RngOutputFirstCell.Offset(1,1).Address ? "; RngOutputFirstCell.Offset(1, 1).Address; " | "
Debug.Print "RngOutputFirstCell.Offset(1,1).Value ? "; RngOutputFirstCell.Offset(1, 1).Value; " | "
Debug.Print "RngOutputFirstCell.Offset(1,1).Formula ? "; RngOutputFirstCell.Offset(1, 1).Formula; " | "
Debug.Print "RngOutputFirstCell.Offset(91,0).Address ? "; RngOutputFirstCell.Offset(91, 0).Address; " | "
Debug.Print "RngOutputFirstCell.Offset(91,0).Value ? "; RngOutputFirstCell.Offset(91, 0).Value; " | "
Debug.Print "RngOutputFirstCell.Offset(91,0).Formula ? "; RngOutputFirstCell.Offset(91, 0).Formula; " | "
Debug.Print "RngOutputFirstCell.Offset(91,1).Address ? "; RngOutputFirstCell.Offset(91, 1).Address; " | "
Debug.Print "RngOutputFirstCell.Offset(91,1).Value ? "; RngOutputFirstCell.Offset(91, 1).Value; " | "
Debug.Print "RngOutputFirstCell.Offset(91,1).Formula ? "; RngOutputFirstCell.Offset(91, 1).Formula; " | "
End Sub
Bit long, yep. Still it should work. Just make sure to properly set those 4 variables at the beginning (WksInput, WksOutput, RngInputFirstCell, RngOutputFirstCell). Notes will guide you. The code writes on previous output but it doesn't clear it (still it can be modify accordingly). It also apply part of the format you've used in your examples (with more details it's possible to completely edit the format).
If you need any clarification, just say please.
i want to implement this recorded macro into a macro for my code, i succesfully transformed "E" row into general, and i want to change that date into Short Date format DD/MM/YYYY the macro i recorded is this one below:
Sub Macro2()
'
' Macro2 Macro
Range("L4").Select
ActiveCell.FormulaR1C1 = "=DATEVALUE(MID(RC[-7],1,10))"
Range("L4").Select
Selection.AutoFill Destination:=Range("L4:L4500"), Type:=xlFillDefault
Range("L4:L4500").Select
Selection.NumberFormat = "m/d/yyyy"
End Sub
I tried it by making the function into the L Column, if it is possible i would like to implement it in one column so all values change and then paste them into the E column
The whole E column is like this:
01-10-2019 52:59:76
02-10-2019 52:59:76
02-10-2019 52:59:76
05-10-2019 52:59:76
And i want them to change into
01/10/2019
02/10/2019
02/10/2019
05/10/2019
This the code i used to transform the whole E column data to the format of dd-mm-yyyy hh:mm:ss to correct the error of some data not changing into the correct format
With ActiveSheet.UsedRange.Columns("E").Cells
Columns("E").NumberFormat = "0"
Columns("E").NumberFormat = "General"
End With
If in '01-10-2019 52:59:76' first two digits means day, try please the next code:
Sub testDateFormat()
Dim lastRow As Long, sh As Worksheet, x As String, i As Long
Set sh = ActiveSheet 'use here your sheet, if not active one
lastRow = sh.Range("E" & sh.Rows.count).End(xlUp).Row
sh.Range("E1:E" & lastRow).NumberFormat = "dd/mm/yyyy"
For i = 2 To lastRow
If sh.Range("E" & i).Value <> Empty Then
If chkFind(CStr(sh.Range("E" & i).Value)) = True Then
x = CStr(sh.Range("E" & i).Value)
sh.Range("E" & i).Value = Format(DateSerial(Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(2), _
Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(1), _
Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(0)), "dd/mm/yyyy")
Else
Debug.Print "Unusual string on the row " & i
End If
End If
Next i
End Sub
Private Function chkFind(strVal As String) As Boolean
On Error Resume Next
If WorksheetFunction.Find(" ", strVal) = 11 Then
chkFind = True
If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
chkFind = False
End If
Else
chkFind = False
End If
On Error GoTo 0
End Function
If first digits represents month, then the last two array (split) elements must be vice versa:
Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(0), _
Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(0))
instead of
Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(1), _
Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(1))
Beforehand, be aware that I just began using VBA, and I have few coding experience prior to it.
I have two sheets:
public
contacts
There is one parameter on column A that is definitely on "contacts" sheet, but may be or not be on column A on "public" sheet.
What I'm doing is:
Checking if the parameter contacts.A2 is on public.A2.
If it is, I need to copy columns, on the exact order:
public: A, C, G.
contacts: E, F.
I've found the following code online, and I'm running some adaptations to it, but I'm stuck.
Sub match()
Dim I, total, frow As Integer
Dim found As Range
total = Sheets("public").Range("A" & Rows.Count).End(xlUp).Row
'MsgBox (total) '(verifica se a contagem está ok)
For I = 2 To total
pesquisa = Worksheets("public").Range("A" & I).Value
Set found = Sheets("contacts").Columns("A:A").Find(what:=pesquisa) 'finds a match
If found Is Nothing Then
Worksheets("result").Range("W" & I).Value = "NO MATCH"
Else
frow = Sheets("contacts").Columns("A:A").Find(what:=pesquisa).Row
Worksheets("result").Range("A" & I).Value = Worksheets("public").Range("A" & frow).Value
Worksheets("result").Range("B" & I).Value = Worksheets("public").Range("C" & frow).Value
Worksheets("result").Range("C" & I).Value = Worksheets("public").Range("G" & frow).Value
Worksheets("result").Range("D" & I).Value = Worksheets("contacts").Range("F" & frow).Value
Worksheets("result").Range("E" & I).Value = Worksheets("contacts").Range("G" & frow).Value
End If
Next I
End Sub
What I expect:
to the code do ignore the line 1, as those are headers;
to eliminate de IF above, since I don't need the "NO MATCH"
to the resulting list to be ordered on ascending order, based on the A column.
Can you help me?
edited to include samples of the data and expected results:
I believe I can simplify my needs with the images above. I want to check a client on the public sheet, grab the manager contacts (emails) from the contacts sheet, and create a list that contains branch, manager, and both e-mails on the results sheet.
Creating those images, I realized I have forgotten to account for the second parameter (manager), as there can be multiple managers on a branch. So this is another parameter to account for.
`Public sheet (image)
Contacts sheet(image)
Result sheet(image)
spreadsheet
`
As per my comments, and your updated question with sample, I do believe that your current results do not match that what you say is required; which is looking for both parameters "Branch" and "Manager". Neither does your expected result look like the columns you wanted to extract according to your question. However, going by your sample data and expected output I tried the following:
Sub BuildList()
'Define your variables
Dim x As Long, y As Long
Dim arr1 As Variant, arr2 As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
'Fill 1st array variable from sheet Contacts
With Sheet1 'Change accordingly
x = .Cells(.Rows.Count, 1).End(xlUp).Row
arr1 = .Range("A2:D" & x).Value
End With
'Fill dictionary with first array
For x = LBound(arr1) To UBound(arr1)
dict.Add arr1(x, 1) & "|" & arr1(x, 2), arr1(x, 3) & "|" & arr1(x, 4)
Next x
'Fill 2nd array variable from sheet Public
With Sheet2 'Change accordingly
x = .Cells(.Rows.Count, 1).End(xlUp).Row
arr2 = .Range("A2:B" & x).Value
End With
'Compare array against dictionary and fill sheet Results
With Sheet3 'Change accordingly
y = 2
For x = LBound(arr2) To UBound(arr2)
If dict.Exists(arr2(x, 1) & "|" & arr2(x, 2)) Then
.Cells(y, 1).Value = arr2(x, 1)
.Cells(y, 2).Value = arr2(x, 2)
.Cells(y, 3).Value = Split(dict(arr2(x, 1) & "|" & arr2(x, 2)), "|")(0)
.Cells(y, 4).Value = Split(dict(arr2(x, 1) & "|" & arr2(x, 2)), "|")(1)
y = y + 1
End If
Next x
End With
End Sub
This solution makes use of arrays and dictionary which should be fast. It has given me the following result:
As David suggested, it would be better to have an input and output sample. Maybe you can try this:
Option Explicit
Public Sub match()
Dim wsPub As Worksheet
Dim wsCon As Worksheet
Dim wsRes As Worksheet
Dim pubRow As Long
Dim conRow As Long
Dim resRow As Long
Dim i As Long
Dim rng As Range
Dim cel As Range
Dim found As Long
Dim order(1 To 5) As Integer
Set wsPub = ThisWorkbook.Worksheets("public")
Set wsCon = ThisWorkbook.Worksheets("contacts")
Set wsRes = ThisWorkbook.Worksheets("result")
pubRow = wsPub.Cells(wsPub.Rows.Count, 1).End(xlUp).Row
conRow = wsCon.Cells(wsPub.Rows.Count, 1).End(xlUp).Row
resRow = wsRes.Cells(wsRes.Rows.Count, 1).End(xlUp).Row
Set rng = wsPub.Range("A2:A" & pubRow)
order(1) = 1
order(2) = 3
order(3) = 7
order(4) = 6
order(5) = 7
For Each cel In rng
If Not IsError(Application.match(cel.Value, wsCon.Range("A2:A" & conRow), 0)) Then
found = Application.match(cel.Value, wsCon.Range("A2:A" & conRow), 0) + 1
resRow = wsRes.Cells(wsRes.Rows.Count, 1).End(xlUp).Row
For i = 1 To 5
If i < 4 Then
wsRes.Cells(resRow, i).Offset(1, 0).Value _
= cel.Offset(0, order(i) - 1).Value
Else
wsRes.Cells(resRow, i).Offset(1, 0).Value _
= wsCon.Cells(found, order(i)).Value
End If
Next
End If
Next
wsRes.Range("A1").AutoFilter
wsRes.AutoFilter.Sort.SortFields.Clear
wsRes.AutoFilter.Sort.SortFields.Add2 Key:= _
Range("A1:A" & resRow), SortOn:=xlSortOnValues, order:=xlAscending, DataOption:= _
xlSortNormal
wsRes.AutoFilter.Sort.Apply
End Sub
I have SUMIF running really really slow. My data has 14,800 Rows and 39 Columns.
I do the following:
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
EDITED TO ADD more potentially relevant code that may be interacting with the SUMIF command
It may be relevant to the speed issue so I'll mention it. I get the user to open a file from wherever they may have stored the report. The file then stays open. Maybe that is a problem. I don't know if it should be some other way.. like I close it but keep the address in mind or something??
FilterType = "Text Files (*.txt),*.txt," & "Comma Separated Files (*.csv),*.csv," & "ASCII Files (*.asc),*.asc," & "All Files (*.*),*.*"
FilterIndex = 4
Title = "File to be Selected"
File_path = Application.GetOpenFilename(FileFilter:=FilterType, FilterIndex:=FilterIndex, Title:=Title)
If File_path = "" Then
MsgBox "No file was selected."
Exit Sub
End If
Set wbSource = Workbooks.Open(File_path)
Original_Name = ActiveWorkbook.Name
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
Set wb1 = ActiveWorkbook
Set ws1 = wb1.Worksheets("Sheet1")
With ws1
FinalColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
FinalRow = .Range("B" & .Rows.Count).End(xlUp).Row
For j = 1 To FinalColumn
If .Cells(1, j).Value = "Effec.Date" Then
Effective_Date_Column = j
ElseIf .Cells(1, j).Value = "FolderId" Then
FolderId_column = j
ElseIf .Cells(1, j).Value = "FolderNotional" Then
FolderNotional_column = j
End If
Next j
'range_Total_Folder_Fixed = .Cells(2, Total_Folder_Column).Address & ":" & .Cells(FinalRow, Total_Folder_Column).Address
range_FolderId_Fixed = .Cells(2, FolderId_column).Address & ":" & .Cells(FinalRow, FolderId_column).Address
range_FolderId_Cell = .Cells(2, FolderId_column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
range_FolderNotional_Fixed = .Cells(2, FolderNotional_column).Address & ":" & .Cells(FinalRow, FolderNotional_column).Address
Everything runs in 8-10 seconds until we come to the lie below. Now the total time jumps to a 150 seconds.
.Range(range_Total_Folder_Fixed).Formula = "=SUMIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "," & range_FolderNotional_Fixed & ")"
Am I doing something wrong? Is there a better (more efficient) way to write a general formula?
EDIT: Code generated Raw Formula
Some of the excel worksheet functions in my code:
.Range(range_Isnumber).Formula = "=(RIGHT(" & range_TradeId_cell & ",2)<> ""IB"")*1"
.Range(range_Is_IB).Formula = "=(RIGHT(" & range_TradeId_cell & ",2)= ""IB"")*1"
.Range(range_Exceptions).Formula = "=(SUMIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "," & range_Isnumber_fixed & ")= COUNTIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "))*1+(SUMIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "," & range_Is_IB_fixed & ")= COUNTIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "))*1 "
.Range("C13").FormulaR1C1 = "=SUM(IF(FREQUENCY(MATCH([SCL_FL_2013_11_30.xlsx]Rest!R2C2:R2321C2,[SCL_FL_2013_11_30.xlsx]Rest!R2C2:R2321C2,0),MATCH([SCL_FL_2013_11_30.xlsx]Rest!R2C2:R2321C2,[SCL_FL_2013_11_30.xlsx]Rest!R2C2:R2321C2,0))>0,1))"
So Stuff like
Range("I2")=SUMIF($H$2:$H$5,H2,$G$2:$G$5)
Where the data could be like
RowG RowH RowI
Alice 1 4
Alice 3 4
Bob 9 17
Bob 8 17
Dan 2 2
EDIT2 : Implementing Sam's solution, I am getting errors:
Set range_FolderId_Fixed = .Range(.Cells(2, FolderId_column), .Cells(FinalRow, FolderId_column))
Set range_FolderId_Cell = .Range(.Cells(2, FolderId_column),.Cells(FinalRow, FolderId_column))
Set range_FolderNotional_Fixed = .Range(.Cells(2, FolderNotional_column), .Cells(FinalRow, FolderNotional_column))
Set range_Total_Folder_Fixed = .Range(.Cells(2, Total_Folder_Column), .Cells(FinalRow, Total_Folder_Column))
.Range(range_Total_Folder_Fixed).Value = SumIf_func(range_FolderId_Fixed, range_FolderId_Cell, range_FolderNotional_Fixed)
I am getting a type application defined or object defined error in the line below.
.Range(range_Total_Folder_Fixed).Value = SumIf_func(range_FolderId_Fixed, range_FolderId_Cell, range_FolderNotional_Fixed)
I have no idea what to do next.
Ok this is what I came up with
Public Function SumIf_func(rng As Range, _
criteria As Range, _
sumRange As Range) As Variant()
Dim rngArr() As Variant
Dim sumArr() As Variant
Dim criteriaArr() As Variant
Dim returnArr() As Variant
Dim temp As Double
rngArr = rng.Value2
sumArr = sumRange.Value2
criteriaArr = criteria.Value2
If UBound(sumArr) <> UBound(rngArr) Then _
Err.Raise 12345, "SumIf_func", "Sum range and check range should be the same size"
If UBound(sumArr, 2) <> 1 Or UBound(rngArr, 2) <> 1 Then _
Err.Raise 12346, "SumIf_func", "Sum range and check range should be a single column"
ReDim returnArr(1 To UBound(criteriaArr), 1 To 1)
For c = LBound(criteriaArr) To UBound(criteriaArr)
returnArr(c, 1) = Application.WorksheetFunction.SumIf(rng, criteriaArr(c, 1), sumRange)
Next c
SumIf_func = returnArr
End Function
This function takes in three ranges:
The range to check
The range where the criteria are
The range where the values to sum are
The range to check and the sum range should both be the same length and only be 1 column across.
The array that is returned will be the same size as the criteria array..
Here is an example of usage:
Public Sub test_SumIf()
Dim ws As Worksheet
Set ws = Sheet1
Dim rng As Range, sumRng As Range, criteria As Range
Set rng = ws.Range("A1:A100")
Set sumRng = ws.Range("B1:B100")
Set criteria = ws.Range("C1:C10")
ws.Range("D1:D10").Value = SumIf_func(rng, criteria, sumRng)
End Sub