Excel VBA - How can dates of different formats be compared - excel

I am trying to compare the dates from two different worksheets which have different formats. The first sheet's format is YYYYMMDD, and the second's is DD/MM/YYYY.
A caveat is the second worksheet's year is incorrect (it written as 2020 and should be 2021). The rows may also be in different orders. The first worksheet's data for the date is input as Text and not Date.
As much as I would like to, I can't change the data on these two sheets, and can instead only output to a third sheet (essentially checking the data for entries with the same date, not counting the incorrect year, and outputting something if some key data is different between them).
For example, if one sheet has...
Date
Price
20210101
500
20210102
1000
20210103
2000
...and the other has...
Date
Price
01/01/2020
500
03/01/2020
3000
02/01/2020
750
...I would want to output this to the third sheet...
Date
Sheet 1 Price
Sheet 2 Price
20210102
1000
750
20210103
2000
3000
I have some VBA code which would work in principal, but only if the formats were identical.
' the columns to check in the first worksheet
Const ws1Date As Integer = 1 'first worksheet, Column A
Const ws1Price As Integer = 2 'first worksheet, Column B
' the columns to check in the second worksheet
Const ws2Date As Integer = 1 'second worksheet, Column A
Const ws2Price As Integer = 2 'second worksheet, Column B
' the columns to write to in the result worksheet
Const resultWsDate As Integer = 1 'result worksheet, Column A
Const resultWsPrice As Integer = 2 'result worksheet, Column B
Const resultWsClientPrice As Integer = 3 'result worksheet, Column C
Dim ws1DateArray As Variant, ws2DateArray As Variant
Dim ws1 As Worksheet, ws2 As Worksheet, resultWs As Worksheet
Set ws1 = Sheets(1) 'the first worksheet
Set ws1 = Sheets(2) 'the second worksheet
Set resultWs = Sheets(3) 'the outputted results
Sub compareFiles()
'-- Store ws1 dates in array --
compareRowMaxLength = ws1.Cells(Rows.Count, ws1Date).End(xlUp).Row
ws1DateArray = ws1.Range(Cells(1, ws1Date).Address, _
Cells(compareRowMaxLength, ws1Date).Address).Value
'-- Store ws2 dates in array --
compareRowMaxLength = ws2.Cells(Rows.Count, ws2Date).End(xlUp).Row
ws2DateArray = ws2.Range(Cells(1, ws2Date).Address, _
Cells(compareRowMaxLength, ws2Date).Address).Value
'-- Store ws1 depth in array --
compareRowMaxLength = resultWs.Cells(Rows.Count, ws1Date).End(xlUp).Row
ws1DepthArray = resultWs.Range(Cells(1, ws1Date).Address, _
Cells(compareRowMaxLength, ws1Depth).Address).Value
'-- Interate through arrays --
For compareRow = 2 To UBound(ws2DateArray, 1)
matchData = 0
On Error Resume Next
matchData = WorksheetFunction.Match(ws2DateArray(compareRow, 1), ws1DateArray, 0)
On Error GoTo 0
' if the date of the current row is found in the second sheet
If matchData <> 0 Then
If ws2.Cells(compareRow, ws2Price).Value <> ws1.Cells(matchData, ws1Price).Value Then
' Copy the matching data to the results worksheet
resultWs.Cells(resultRow, resultWsDate).Value = ws1.Cells(matchData, ws1Date).Value
resultWs.Cells(resultRow, resultWsPrice).Value = ws1.Cells(matchData, ws1Price).Value
resultWs.Cells(resultRow, resultWsClientPrice).Value = ws2.Cells(compareRow, ws2Price).Value
End If
End If
Next compareRow
End Sub
I have tried to reformat the date from sheet 2 using something like this within the For loop...
ReplacementYear = 2021
FormatDay = Left(ws2DateArray(compareRow, 1), 2)
FormatMonth = Mid(ws2DateArray(compareRow, 1), 4, 2)
FormattedDate = CStr(ReplacementYear) + CStr(FormatMonth) + CStr(FormatDay)
...and changing matchData = WorksheetFunction.Match(ws2DateArray(compareRow, 1), ws1DateArray, 0) to matchData = WorksheetFunction.Match(FormatDate, ws1DateArray, 0) but it seems Match can't work this way.
Thanks very much for any help!

This may well not be the best solution, but in the off-chance this helps anyone in the future, this is what I came up with.
I can't modify the data in the other worksheets, but I can copy the data into a new worksheet, modify that, and then remove it later on.
' copy the worksheets and modify dates
ws1.Copy After:=Sheets(4)
ws2.Copy After:=Sheets(5)
Set modifyWs1 = Sheets(4)
Set modifyWs2 = Sheets(5)
' fix dates and apply consistent formatting to dates and depth
modifyWs1 .Activate
Dim ws1DateCol As Range
For Each ws1DateCol In Range(Range("A2"), Range("A2").End(xlDown))
ws1DateCol.NumberFormat = "yyyymmdd" ' confirm date format
ws1DateCol.Value = ws1DateCol.Text ' change cells to text so they can be Matched
ws1DateCol.NumberFormat = "#"
Next
' fix dates and apply consistent formatting to dates and depth
modifyWs2.Activate
Dim ws2DateCol As Range
For Each ws2DateCol In Range(Range("A2"), Range("A2").End(xlDown))
ws2DateCol.Value = DateAdd("yyyy", 1, ws2DateCol.Value) ' add 1 to the year, as 2020 should be 2021
ws2DateCol.NumberFormat = "yyyymmdd" ' change date format
ws2DateCol.Value = ws2DateCol.Text ' change cells to text so they can be Matched
ws2DateCol.NumberFormat = "#"
Next
The data from these new columns are then put into the ws1DateArray and ws2DateArray instead, and the WorksheetFunction.Match(ws2DateArray(compareRow, 1), ws1DateArray, 0) works as desired.

Related

Excel VBA - Copying data based on two parameters into another worksheet

I'm trying to copy data from one sheet that contains raw data (over 30 columns and 300000 rows) into other sheets that split them into organized form.
In the DATA sheet I have repetitive ID's in column A, case numbers in column B which are unique and dates of cases in column J (multiple case numbers have the same date).
My goal is to copy case numbers into worksheets that are named with ID's from col A. In the target sheet I have single dates in col A (ex. from 3/01/2021 in A1 to 3/31/2021 in A31). The case numbers need to be transposed so they appear in columns next to each other but they have the same date.
I cannot use the ID's names in the code because it varies every month so I suppose that the code needs to work as some sort of comparison tool.
This should be close: it will add the sheets if they don't already exist.
Sub Copy_to_ID_sheet()
Dim impdate As Date, startDate As Date, daysToFillDown As Long
Dim finalrow As Long
Dim i As Long, numSheets As Long
Dim shipment As String, m
Dim ID As String, wsDane As Worksheet, dict As Object, ws As Worksheet
startDate = DateSerial(2021, 3, 1) 'adjust as needed
daysToFillDown = 31 '...and here
Set wsDane = ThisWorkbook.Sheets("Dane")
numSheets = ThisWorkbook.Worksheets.Count
Set dict = CreateObject("scripting.dictionary")
For i = 2 To wsDane.Cells(Rows.Count, "A").End(xlUp).Row
impdate = wsDane.Cells(i, 10).Value
shipment = wsDane.Cells(i, 2).Value
ID = Sheets("Dane").Cells(i, 1).Value
'already seen this ID and have a matching sheet?
If Not dict.exists(ID) Then
Set ws = Nothing
On Error Resume Next
Set ws = ThisWorkbook.Sheets(ID) 'does the sheet already exist?
On Error GoTo 0
If ws Is Nothing Then
'no existing sheet, so add a new one
Set ws = ThisWorkbook.Worksheets.Add( _
after:=ThisWorkbook.Worksheets(numSheets))
numSheets = numSheets + 1
ws.Name = ID
'add dates to the new sheet
With ws.Range("A1")
.NumberFormat = "mm/dd/yyyy" 'or whatever
.Value = startDate
.AutoFill Destination:=.Resize(daysToFillDown, 1)
End With
End If
Set dict(ID) = ws 'save in dictionary
Else
Set ws = dict(ID) 'get the existing sheet
End If
'match the date to the destination sheet
m = Application.Match(CLng(impdate), ws.Range("A1:A40"), 0)
If Not IsError(m) Then
'got a date match - add the shipment to the next available slot
ws.Cells(m, Columns.Count).End(xlToLeft).Offset(0, 1).Value = shipment
End If
Next i
End Sub

How to copy and paste unique data according to date, when the dates are repeated?

I am trying to copy data from one sheet to another according to matching dates and so far I can do this but the problem is that the most recent data for a corresponding date over writes all other data for the same date.
E.G.
I want to copy data from sheet 2 column 1 (based on the date in column 2)
I want to paste this data into sheet 1 column 2 (Based on the date in column 1)
As can be seen, only the last number from sheet 2 column 1 which corresponds to the respective date is pasted into ALL corresponding dates in sheet 1 column 2.
Instead, if there are two dates, I want two different numbers( from sheet 2 column 1 ) to be pasted into sheet 1 column 2.
My original code is as follows:
Sub Macroturnip()
'
' Macroturnip Macro
'
Dim Row As Double 'row is the row variable for the destination spreadsheet
Dim i As Date
Dim x As Long 'x is the row variable for the source spreadsheet
For Row = 1 To 825
i = Sheets("1").Cells(Row, 1)
If i <> DateSerial(1900, 1, 0) Then
'DateSerial(1900, 1, 0) --> this is the default for no data in the field, i.e. i want to skip these
For x = 2 To 450
If Sheets("2").Cells(x, 2) = Sheets("1").Cells(Row, 1) Then
Sheets("2").Select
Cells(x, 1).Select
Selection.Copy
Sheets("1").Select
Cells(Row, 2).Select
ActiveSheet.Paste
End If
Next x
End If
Next Row
End Sub
Is good practice to avoid using variable names that are already representing something in code, i.e.: Row.
Row number should a be a integer/long type
You should declare and assign your worksheets to variables
Most code in VBA can be written without using .Select, though sometimes you might need it, this is not one of those times... and you should avoid at all cost using it in a nested loop. For ex:
Sheets("2").Select
Cells(x, 1).Select
Selection.Copy
Can be easily rewritten as such:
Sheets("2").Cells(x, 1).Copy
This might need some better logic, but based on your screenshots, it works:
Sub Macroturnip()
'
' Macroturnip Macro
'
Dim wsDst As Worksheet: Set wsDst = ActiveWorkbook.Sheets("1")
Dim lRowDst As Long: lRowDst = wsDst.Cells(wsDst.Rows.Count, 1).End(xlUp).Row
Dim wsSrc As Worksheet: Set wsSrc = ActiveWorkbook.Sheets("2")
Dim lRowSrc As Long: lRowSrc = wsSrc.Cells(wsSrc.Rows.Count, 1).End(xlUp).Row
Dim rngFind As Range
Dim Rs As Long, Rd As Long 'row is the row variable for the destination spreadsheet
For Rd = 2 To lRowDst
If wsDst.Cells(Rd, 1) <> "" Then
'DateSerial(1900, 1, 0) --> this is the default for no data in the field, i.e. i want to skip these
For Rs = 2 To lRowSrc
If wsDst.Cells(Rd, 1) = wsSrc.Cells(Rs, 2) Then
Set rngFind = wsDst.Range("B2:B" & Rd).Find(wsSrc.Cells(Rs, 1), Lookat:=xlWhole)
If rngFind Is Nothing Then
wsDst.Cells(Rd, 2) = wsSrc.Cells(Rs, 1).Value
Exit For 'No need to keep checking, move on
End If
Set rngFind = Nothing
End If
Next Rs
End If
Next Rd
End Sub
PS: I've assumed that by Sheets("2") you actually referred to a sheet named 2, and not Sheet2 or Sheets(2) which though look similar, are not the same thing.

Excel 2007 Formula - Collapse cells and its data

I'm currently using excel 2010 and have some data I'm trying to transform so to speak and output the results into sheet 2. I'm not sure where to start and was hoping for some guidance.
The image below is only a sample set of data. The actual spreadsheet consists of 92 rows and 78 columns. The first three columns are name and address and the rest are very similar to what is shown in the image. Some cells have a value, a zero, or blank. The rows in red is what I would like to accomplish.
Here is a solution using VBA.
It assumes that your existing sheet is named "Sheet1", and the new sheet exists and is named "Sheet2".
Option Explicit
Sub CollapseData()
Dim RowNbr As Long
Dim SrcColNbr As Long
Dim DestColNbr As Long
Dim MaxRowNbr As Long
Dim PeriodNbr As Long
Dim MaxPeriodNbr As Long
Dim SrcSheetName As String
Dim DestSheetName As String
Dim SrcSheet As Worksheet
Dim DestSheet As Worksheet
SrcSheetName = "Sheet1"
DestSheetName = "Sheet2"
Set SrcSheet = ThisWorkbook.Worksheets(SrcSheetName)
Set DestSheet = ThisWorkbook.Worksheets(DestSheetName)
' Determine last row number in use
MaxRowNbr = SrcSheet.Cells(Rows.Count, 1).End(xlUp).Row
' Copy name, addr1, and addr2 headings
For DestColNbr = 1 To 3
Call CopyCell(SrcSheet.Cells(1, DestColNbr), DestSheet.Cells(1, DestColNbr))
Next DestColNbr
' Determine number of period columns in use
MaxPeriodNbr = SrcSheet.Cells(1, Columns.Count).End(xlToLeft).Column - 3
' Generate date headings
DestColNbr = 4
For PeriodNbr = 1 To MaxPeriodNbr
DestSheet.Cells(1, DestColNbr) = "date" & Format(PeriodNbr, "##0")
DestSheet.Cells(1, DestColNbr + 1) = "amount" & Format(PeriodNbr, "##0")
DestColNbr = DestColNbr + 2
Next PeriodNbr
' Copy data from Sheet1 to Sheet2
For RowNbr = 2 To MaxRowNbr
' Copy name and address
For DestColNbr = 1 To 3
Call CopyCell(SrcSheet.Cells(RowNbr, DestColNbr), DestSheet.Cells(RowNbr, DestColNbr))
Next DestColNbr
DestColNbr = 4
For SrcColNbr = 4 To MaxPeriodNbr + 3
If SrcSheet.Cells(RowNbr, SrcColNbr) <> 0 Then
' Copy date from Sheet1 to Sheet2
Call CopyCell(SrcSheet.Cells(1, SrcColNbr), DestSheet.Cells(RowNbr, DestColNbr))
' Copy amount from Sheet1 to Sheet2
Call CopyCell(SrcSheet.Cells(RowNbr, SrcColNbr), DestSheet.Cells(RowNbr, DestColNbr + 1))
DestColNbr = DestColNbr + 2
End If
Next SrcColNbr
Next RowNbr
End Sub
Private Sub CopyCell(FromCell As Range, ToCell As Range)
FromCell.Copy
ToCell.PasteSpecial xlPasteValues
ToCell.PasteSpecial xlPasteFormats
End Sub
Here is how you can do it for the example you have shown. It should be simple to replicate the formulas for the whole set of data you have.
To get the first date that has an amount greater than zero, i am doing an array multiplication of the amounts array > 0 and the dates array. then i invert this array (1/array). AGGREGATE function gives you the largest value after ignoring the erros(#div0). Inverting again gives you the first date that has an amount greater than 0.
for the next date, i include one more criteria by checking if the date array has date greater than the date previously calculated, thus giving me the next date.
The formula for amounts are basically HLOOKUPs for the date that was retrieved.
for date 1
=1/AGGREGATE(14,6,1/((D2:I2>0)*D1:I1),1)
for amount 1
=HLOOKUP(D6,$D$1:$I$2,2,FALSE)
for date 2
=1/AGGREGATE(14,6,1/(($D$2:$I$2>0)*($D$1:$I$1>D6)*$D$1:$I$1),1)
for amount 2
=HLOOKUP(F6,$D$1:$I$2,2,FALSE)
for date 3
=1/AGGREGATE(14,6,1/(($D$2:$I$2>0)*($D$1:$I$1>F6)*$D$1:$I$1),1)
for amount 3
=HLOOKUP(H6,$D$1:$I$2,2,FALSE)

Copy a set of data multiple times based on criteria on another sheet

Excel 2010. I am trying to write a macro that could copy a set of data multiple times based on criteria on another sheet, but I've been stuck for a long time. I very much appreciate any help that could be offered to help me solve this problem.
Step 1: In the "Criteria" worksheet, there are three columns in which each row contains a specific combination of data. The first set of combination is "USD, Car".
Criteria worksheet
Step 2: Then the macro will move to the Output worksheet (please refer to the below link for screenshots), and then filter column A and B with the first set of criteria "USD" and "Car" in the "Criteria" worksheet.
Step 3: Afterwards, the macro will copy the filtered data into the last blank row. But the tricky part here is that, the filtered data has to be copied two times (as the "Number of set" column in the "Criteria" tab is 3 in this combination, and it doesn't have to copy the data three times since the filtered data would be treated as the first set of data)
Step4: After the filtered data have been copied, the "Set" column D will need to fill in the corresponding number of set that the rows are in. Therefore, in this 1st example, cell D2 and D8 will have "1" value, cell D14-15 will have "2" value, and cell D16-17 will have "3" value.
Step5: The macro will then move back to the "Criteria" worksheet and continue to based on the 2nd set of combination "USD, Plane" to filter the data in the "Output" worksheet. Again, it will copy the filtered data based on the "Number of set" in the "Criteria" worksheet. This process will continue until all the different combinations in the "Criteria" worksheet have been processed.
Output worksheet
Ok sorry for delay, here is a working version
you just have to add a sheet called "BF" because the autofilter count wasn't working properly so I had to use another sheet
Sub testfct()
Dim ShC As Worksheet
Set ShC = ThisWorkbook.Sheets("Criteria")
Dim EndRow As Integer
EndRow = ShC.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To EndRow
Get_Filtered ShC.Cells(i, 1), ShC.Cells(i, 2), ShC.Cells(i, 3)
Next i
End Sub
Sub Get_Filtered(ByVal FilterF1 As String, ByVal FilterF2 As String, ByVal NumberSetsDisered As Integer)
Dim NbSet As Integer
NbSet = 0
Dim ShF As Worksheet
Set ShF = ThisWorkbook.Sheets("Output")
Dim ColCr1 As Integer
Dim ColCr2 As Integer
Dim ColRef As Integer
ColCr1 = 1
ColCr2 = 2
ColRef = 4
If ShF.AutoFilterMode = True Then ShF.AutoFilterMode = False
Dim RgTotal As String
RgTotal = "$A$1:$" & ColLet(ShF.Cells(1, Columns.Count).End(xlToLeft).Column) & "$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row
ShF.Range(RgTotal).AutoFilter field:=ColCr1, Criteria1:=FilterF1
ShF.Range(RgTotal).AutoFilter field:=ColCr2, Criteria1:=FilterF2
'Erase Header value, fix? or correct at the end?
ShF.AutoFilter.Range.Columns(ColRef).Value = 1
Sheets("BF").Cells.ClearContents
ShF.AutoFilter.Range.Copy Destination:=Sheets("BF").Cells(1, 1)
Dim RgFilt As String
RgFilt = "$A$2:$B" & Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row '+ 1
Dim VR As Integer
'Here was the main issue, the value I got with autofilter was not correct and I couldn't figure out why....
'ShF.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count
'Changed it to a buffer sheet to have correct value
VR = Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row - 1
Dim RgDest As String
ShF.AutoFilterMode = False
'Now we need to define Set's number and paste N times
For k = 1 To NumberSetsDisered - 1
'define number set
For j = 1 To VR
ShF.Cells(Rows.Count, 1).End(xlUp).Offset(j, 3) = k + 1
Next j
RgDest = "$A$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":$B$" & (ShF.Cells(Rows.Count, 1).End(xlUp).Row + VR)
Sheets("BF").Range(RgFilt).Copy Destination:=ShF.Range(RgDest)
Next k
ShF.Cells(1, 4) = "Set"
Sheets("BF").Cells.ClearContents
'ShF.AutoFilterMode = False
End Sub
And the function to get column letter using an integer input :
Function ColLet(x As Integer) As String
With ActiveSheet.Columns(x)
ColLet = Left(.Address(False, False), InStr(.Address(False, False), ":") - 1)
End With
End Function

How to find minimum, select the corresponding values, copy and paste the values to a new sheet

Following is my problem description
A B C D
1 H1 H2 H3 H4
2 1 3 4 2
3 2 4 1 8
4 3 1 6 1
5 4 2 8 5
First row has the headings. Column A has the serial number of the table. Columns B, C, and D are values coming out from some calculations. I want to write a VBA code such that the code finds the minimum value in the Column D, selects all the corresponding values of the row, copies and pastes just the values in a sheet named NewSheet.
For the given case above, the VBA code should identify that the Cell D4 has the minimum value, it should select the corresponding values in row 4 (from cells B4, C4 and D4), copy these selected values and paste the values in the cells P2,Q2 and R2 of 'NewSheet'.
Since I am just a beginner, it will be highly appreciated if the responder can provide some comments that will help me to understand the code.
This will do the trick.
Option Explicit ' Forces you to declare variables. Helps prevent stupid mistakes.
Sub Rabbit()
' Declare variables. Can also spread this throughout your code...
Dim rngData As Range
Dim rngTarget As Range
Dim varData As Variant
Dim iCounter As Long
Dim iMinH4 As Long
Dim dblMinH4 As Double
Dim shtNew As Worksheet
' Where to get the data from (H1...H4 headers not included here)
Set rngData = Worksheets("Sheet1").Range("A2").Resize(4, 4)
' Get all data from sheet at once. Faster than interrogating sheet multiple times.
varData = rngData
' Get first entry. This is the minimum so far, by definition...
iMinH4 = 1
dblMinH4 = varData(1, 4)
' Go through all other entries to see which is minimum.
For iCounter = LBound(varData, 1) +1 To UBound(varData, 1) ' +1 since first entry already checked
If varData(iCounter, 4) < dblMinH4 Then
' This is the minimum so far.
dblMinH4 = varData(iCounter, 4)
iMinH4 = iCounter
Else
' This is not the minimum.
' Do nothing.
End If
Next iCounter
' If creating new sheet is necessary, uncomment this:
'Set shtNew = ActiveWorkbook.Worksheets.Add
'shtNew.Name = "NewSheet"
' Where should the values go?
Set shtNew = ActiveWorkbook.Worksheets("NewSheet")
Set rngTarget = shtNew.Range("P2:R2")
' Copy the values over to NewSheet.
rngData.Cells(iMinH4, 1).Resize(1, 3).Copy rngTarget
End Sub
Does this work?
This macro can be improved by writing a function that returns a column in a specified worksheet based on the column header. Then you would not have to hardcode the column numbers 4 and 16.
Dim newSheet As Worksheet
Dim yourWorksheet As Worksheet
Dim searchArea As Range
Dim searchResult As Range
Dim yourWorkbook As String
Dim rowMinimum As Long
Dim minimumValue As Long
Dim columnSearch As Integer
Dim columnNew As Integer
columnSearch = 4
columnNew = 16
yourWorkbook = [workbook name]
Set yourWorksheet = Workbooks(yourWorkbook).Worksheets([worksheet name])
Set newSheet = Workbooks(yourWorkbook).Worksheets("NewSheet")
'Select all the cells in the column you want to search down to the first empty
'cell.
Set searchArea = yourWorksheet.Range(yourWorksheet.Cells(2, columnSearch), _
yourWorksheet.Cells(yourWorksheet.Cells(2, columnSearch).End(xlDown).Row, _
columnSearch))
'Determine the minimum value in the column.
minimumValue = Application.Min(searchArea)
'Find the row that contains the minimum value.
Set searchResult = yourWorksheet.Columns(columnSearch).Find(What:=minimumValue, _
After:=yourWorksheet.Cells(1, columnSearch), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False)
'Store the row that contains the minimum value in a variable.
rowMinimum = searchResult.Cells.Row
'Copy the other cells in the row containing the minimum value to the new
'worksheet.
yourWorksheet.Range(yourWorksheet.Cells(rowMinimum, 1), _
yourWorksheet.Cells(rowMinimum, columnSearch - 1)).Copy _
Destination:=newSheet.Cells(2, columnNew)

Resources