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

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
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
97
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
951
davidepstein22
D
K
  • Question Question
Auto Sort (Descinding) based on a column header using VBA
Replies
1
Views
253
Fluff
Fluff

Forum statistics

Threads
1,223,903
Messages
6,175,289
Members
452,631
Latest member
a_potato

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