VBA - Take data of nearest same weekday and non-zero

[navafolk]

I have raw data of each month in separate excel files, example:

September file: 2020-09.xlsx

Date​	Batch​	Value1​	Value2​
23/09/2020​	1​	11​	12​
23/09/2020​	2​	10​	10​
30/09/2020​	1​	0​	0​

October file: 2020-10.xlsx

Date​	Batch​	Value1​	Value2​
01/10/2020​	1​	3​	3​
01/10/2020​	2​	10​	11​
01/10/2020​	3​	11​	12​

Please help to prepare VBA script to take value from raw data files for set of target days, which is raw data of nearest same weekdays with target days and non-zero value.

Target date​	Data date​	Data value​
07/10/2020​	23/09/2020​	43​
08/10/2020​	01/10/2020​	50​

in which Data date is nearest same weekday with Target date and is non-zero value; Target value is total of Value1+Value2 of all batch of that Data date. Please help, great thanks.

 

[navafolk]

anyone, please help.

 

[Dossfm0q]

It's a Pleasure to Be of Service

{Some need to be edit as you need}
Such as you File Paths (Should be edit or move all Files onto "Desktop" )
DefltPath = Environ("USERPROFILE") & "\Desktop"
please Feedback

2020-09.xlsx
	A	B	C	D
1	Date	Batch	Valu1	Valu2
2	9/23/2020	1	11	12
3	9/23/2020	2	10	10
4	9/30/2020	1		0
Sheet1

2020-10.xlsx
	A	B	C	D
1	Date	Batch	Valu1	Valu2
2	10/1/2020	1	3	3
3	10/1/2020	2	10	11
4	10/1/2020	1	11	12
Sheet1

Data Workbook.xlsm
	A	B	C
1	Target Date	Data Date	Data Value
2		9/23/2020	43
3		10/1/2020	50
4
Sheet1

Sub getData()
Application.ScreenUpdating = False
Dim WB As Workbook, WB09 As Workbook, WB10 As Workbook
Dim ws As Worksheet, ws09 As Worksheet, ws10 As Worksheet
Dim Rng As Range, Tbl09 As Range, Tbl10 As Range, DtRng09 As Range, Val1Rng09 As Range, Val2Rng09 As Range, DtRng10 As Range, Val1Rng10 As Range, Val2Rng10 As Range
Dim DefltPath As String
Dim SrtdDate As String
DefltPath = Environ("USERPROFILE") & "\Desktop"
Set WB = ThisWorkbook
Set ws = WB.Worksheets(1)
Set WB09 = Workbooks.Open(DefltPath & "\2020-09.xlsx")
Set ws09 = WB.Worksheets(1)

Set WB10 = Workbooks.Open(DefltPath & "\2020-10.xlsx")
Set ws10 = WB.Worksheets(1)

Set Tbl09 = WB09.Worksheets(1).Range("A1:D4")
Set Tbl10 = WB10.Worksheets(1).Range("A1:D4")

SrtdDate1 = ""
SrtdDate2 = ""
SumPrdct1 = ""
SumPrdct2 = ""
Set DtRng09 = Tbl09.Cells(2, 1).Resize(Tbl09.Rows.Count - 1, 1).Columns(1).Cells
Set Val1Rng09 = Tbl09.Cells(2, 3).Resize(Tbl09.Rows.Count - 1, 1).Cells
Set Val2Rng09 = Tbl09.Cells(2, 4).Resize(Tbl09.Rows.Count - 1, 1).Cells

Set DtRng10 = Tbl10.Cells(2, 1).Resize(Tbl10.Rows.Count - 1, 1).Columns(1).Cells
Set Val1Rng10 = Tbl10.Cells(2, 3).Resize(Tbl10.Rows.Count - 1, 1).Cells
Set Val2Rng10 = Tbl10.Cells(2, 4).Resize(Tbl10.Rows.Count - 1, 1).Cells

For Each Rng In DtRng09

    With Rng
    If InStr(1, SrtdDate1, .Value, vbTextCompare) = 0 And (.Offset(0, 2) <> 0 Or .Offset(0, 3) <> 0) Then
    SrtdDate1 = SrtdDate1 & IIf(SrtdDate1 <> "", ";", "") & .Value
 
    SumPrdct1 = SumPrdct1 & IIf(SumPrdct1 <> "", ";", "") & Evaluate("IFERROR(SUMPRODUCT(--(" & "'[" & WB09.Name & "]" & ws09.Name & "'!" & DtRng09.Address & "=VALUE(" & "'[" & WB09.Name & "]" & ws09.Name & "'!" & .Address & "))," & "'[" & WB09.Name & "]" & ws09.Name & "'!" & Val1Rng09.Address & "+" & "'[" & WB09.Name & "]" & ws09.Name & "'!" & Val2Rng09.Address & "),"""")")
 
    End If
    End With

Next


For Each Rng In DtRng10

    With Rng
    If InStr(1, SrtdDate2, .Value, vbTextCompare) = 0 And (.Offset(0, 2) <> 0 Or .Offset(0, 3) <> 0) Then
    SrtdDate2 = SrtdDate2 & IIf(SrtdDate2 <> "", ";", "") & .Value
 
    SumPrdct2 = SumPrdct2 & IIf(SumPrdct2 <> "", ";", "") & Evaluate("IFERROR(SUMPRODUCT(--(" & "'[" & WB10.Name & "]" & ws10.Name & "'!" & DtRng10.Address & "=VALUE(" & "'[" & WB10.Name & "]" & ws10.Name & "'!" & .Address & "))," & "'[" & WB10.Name & "]" & ws10.Name & "'!" & Val1Rng10.Address & "+" & "'[" & WB10.Name & "]" & ws10.Name & "'!" & Val2Rng10.Address & "),"""")")
 
    End If
    End With

Next
TtlSrtdDate = SrtdDate1 & ";" & SrtdDate2
TtlSumPrdct = SumPrdct1 & ";" & SumPrdct2


With ws
 
    .Range("A1:C1") = Array("Target Date", "Data Date", "Data Value")
     LSTRW = .Cells(Rows.Count, 2).End(xlUp).Row
    .Range("B2:B" & LSTRW + 1).ClearContents
 
    ArrDate = WorksheetFunction.Transpose(Split(TtlSrtdDate, ";"))
    .Range("B2:B" & UBound(ArrDate) + 1).Value = ArrDate

    ArrVal = WorksheetFunction.Transpose(Split(TtlSumPrdct, ";"))
 
    .Range("c2:C" & UBound(ArrDate) + 1).Value = ArrVal
 
    With .Range("A1:C" & UBound(ArrDate) + 1)
        .WrapText = False
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
 
    End With


 
    .Sort.SortFields.Clear
    .Sort.SortFields.Add2 Key:=Range("B2:B" & LSTRW), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange Range("B2:C" & LSTRW)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

.Activate
End With

    WB.Activate
    Application.WindowState = xlMaximized
    ActiveWindow.WindowState = xlMaximized
 
Application.ScreenUpdating = True
 

End Sub