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

navafolk

New Member
Joined
Jul 22, 2015
Messages
17
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.
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop

Dossfm0q

Banned User
Joined
Mar 9, 2009
Messages
570
Office Version
  1. 2019
Platform
  1. Windows
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
ABCD
1DateBatchValu1Valu2
29/23/202011112
39/23/202021010
49/30/202010
Sheet1


2020-10.xlsx
ABCD
1DateBatchValu1Valu2
210/1/2020133
310/1/202021011
410/1/202011112
Sheet1


Data Workbook.xlsm
ABC
1Target DateData DateData Value
29/23/202043
310/1/202050
4
Sheet1


VBA Code:
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
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,129,517
Messages
5,636,797
Members
416,941
Latest member
shazzaxyz

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top