VBA Sumif based on column headers

M

milanso

New Member
Joined
May 17, 2017
Messages
4
Hi,
I have two worksheets. The first contains the production plan with dates for column headers and products for rows.

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Product[/TD]
[TD]7.2.2018[/TD]
[TD]7.3.2018[/TD]
[TD]7.4.2018[/TD]
[TD]7.5.2018[/TD]
[TD]7.6.2018[/TD]
[TD]7.7.2018[/TD]
[TD]7.8.2018[/TD]
[TD]7.9.2018[/TD]
[/TR]
[TR]
[TD]a[/TD]
[TD]150[/TD]
[TD]200[/TD]
[TD]550[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]b[/TD]
[TD]50[/TD]
[TD]200[/TD]
[TD]400[/TD]
[TD]600[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]c[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]600[/TD]
[TD]500[/TD]
[TD]500[/TD]
[TD]400[/TD]
[TD]0[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]d[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]800[/TD]
[TD]1000[/TD]
[TD]600[/TD]
[TD]250[/TD]
[TD]100[/TD]
[/TR]
</tbody>[/TABLE]

I needed to create a second worksheet based on the first one, but with shipping dates instead of production dates, based on criteria like,
if date 1 is tuesday, then it ships on friday, etc. Since we have two shipments per week, we will have several date headers repeating, like this:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Product[/TD]
[TD]7.5.2018[/TD]
[TD]7.5.2018[/TD]
[TD]7.5.2018[/TD]
[TD]7.9.2018[/TD]
[TD]7.9.2018[/TD]
[TD]7.9.2018[/TD]
[TD]7.9.2018[/TD]
[TD]7.12.2018[/TD]
[/TR]
[TR]
[TD]a[/TD]
[TD]150[/TD]
[TD]200[/TD]
[TD]550[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]b[/TD]
[TD]50[/TD]
[TD]200[/TD]
[TD]400[/TD]
[TD]600[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]c[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]600[/TD]
[TD]500[/TD]
[TD]500[/TD]
[TD]400[/TD]
[TD]0[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]d[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]800[/TD]
[TD]1000[/TD]
[TD]600[/TD]
[TD]250[/TD]
[TD]100[/TD]
[/TR]
</tbody>[/TABLE]

Ive managed to do all this, but I need the columns summed for the same dates, and I'm stuck.
This should be the final result:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Product[/TD]
[TD]7.5.2018[/TD]
[TD]7.9.2018[/TD]
[TD]7.12.2018[/TD]
[/TR]
[TR]
[TD]a[/TD]
[TD]900[/TD]
[TD]0[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]b[/TD]
[TD]650[/TD]
[TD]600[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]c[/TD]
[TD]600[/TD]
[TD]1400[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]d[/TD]
[TD]0[/TD]
[TD]2650[/TD]
[TD]100[/TD]
[/TR]
</tbody>[/TABLE]


Here's the code:

Code: 
Option Explicit

Sub Plan()
Dim d As Object
Dim i As Range, n As Range, v As Range, h As Range
Dim wbO As Workbook
Dim wsPlan As Worksheet, wsShip As Worksheet
Dim lRowP As Long, lColP As Long, lRowS As Long, lColS As Long, lRowS2 As Long, lColS2 As Long, rowNrI As Long, colNrI As Long




Set wbO = ThisWorkbook
Set wsPlan = wbO.Sheets("plan")
Set wsShip = wbO.Sheets("shipments")


With Application
        .ScreenUpdating = False
        .EnableEvents = False
End With


lRowP = wsPlan.Cells(wsPlan.Rows.Count, 1).End(xlUp).Row
lColP = wsPlan.Cells(1, wsPlan.Columns.Count).End(xlToLeft).Column

'Calculates which shipment date it is and writes over new value

For Each i In wsPlan.Range(wsPlan.Cells(1, 2), wsPlan.Cells(1, lColP))
    If Weekday(i.Value) = 1 Then
        i = DateAdd("d", 3, i.Value)
    ElseIf Weekday(i.Value) = 2 Then
        i = DateAdd("d", 2, i.Value)
    ElseIf Weekday(i.Value) = 3 Then
        i = DateAdd("d", 6, i.Value)
    ElseIf Weekday(i.Value) = 4 Then
        i = DateAdd("d", 5, i.Value)
    ElseIf Weekday(i.Value) = 5 Then
        i = DateAdd("d", 4, i.Value)
    ElseIf Weekday(i.Value) = 6 Then
        i = DateAdd("d", 5, i.Value)
    ElseIf Weekday(i.Value) = 7 Then
        i = DateAdd("d", 4, i.Value)
    End If
Next i

'Clears Shipment sheet

If wsShip.Range("A1").Value <> 0 Then
    lRowI = wsShip.Cells(wsShip.Rows.Count, 1).End(xlUp).Row
    lColI = wsShip.Cells(1, wsShip.Columns.Count).End(xlToLeft).Column
    wsShip.Range(wsShip.Cells(1, 1), wsShip.Cells(lRowI, lColI)).ClearContents
End If

'copies first column with the Products to new sheet

wsPlan.Range(wsPlan.Cells(1, 1), wsPlan.Cells(lRowP, 1)).Copy wsShip.Range("A1")

'Creates scripting dictionary from the shipping dates and pastes unique values to new sheet

Set d = CreateObject("scripting.dictionary")
For Each n In wsPlan.Range(wsPlan.Cells(1, 2), wsPlan.Cells(1, lColP))
    If Len(n.Value) > 0 Then
        If Not d.Exists(n.Value) Then d.Add n.Value, 1
    End If
Next n


wsShip.Range("B1").Resize(1, UBound(d.keys) + 1).Value = d.keys


lRowS2 = wsShip.Cells(wsShip.Rows.Count, 1).End(xlUp).Row
lColS2 = wsShip.Cells(1, wsShip.Columns.Count).End(xlToLeft).Column

'Tried with sumif but stuck

For rowNrI = 2 To lRowI2
    For Each v In wsShip.Range(wsShip.Cells(rowNrI, 2), wsShip.Cells(rowNrI, lColI2))
            v = Application.WorksheetFunction.SumIf(wsPlan.Range(wsPlan.Cells(1, 2), wsPlan.Cells(rowNrI, lColP)), d.keys, wsPlan.Range(wsPlan.Cells(rowNrI, 2), wsPlan.Cells(rowNrI, lColP)))
    Next v
Next rowNrI


With Application
        .ScreenUpdating = True
        .EnableEvents = True
End With


End Sub
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
You must log in or register to reply here.

Similar threads

R
  • Solved
VBA: Merging columns based on header
2
Replies
12
Views
1K
ruinedelf
R
A
  • Solved
Multiple columns to populate data on userform based on header in combobox
Replies
4
Views
120
abdo meghari
A
J
  • Solved
Date Issue Between Users
2
Replies
18
Views
1K
JBDB
J
D
  • Question Question
VBA code works when called directly, but not from another routhine
Replies
7
Views
964
davidepstein22
D
K
  • Question Question
Auto Sort (Descinding) based on a column header using VBA
Replies
1
Views
259
Fluff
Fluff

Forum statistics

Threads
1,224,823
Messages
6,181,183
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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
Back
Top