Add rows with actions in different weeks based on range values

D

ddewilt

New Member
Joined
Sep 18, 2017
Messages
26
Hi,

I've got case right here..
I have 2 sheets: On Sheet 1 on row 3 in Column E there's a name and from Column F to AD are weeknumbers (1 to 51). Per action you can fill in a weeknumber which that action has to take place. On Sheet 2 I need to insert a name with rows depending how many actions that week need to be done.

SHEET 1
Toprow (row2), beginning on column E and the actions from F to AD:
Columns: E F G ... .... ...
ROW 2 :Name | Action 1 | Action 2 | Action 3 | Action 4 | Action 5 | Action 6 | Action 7 | Action 8 | Action 9 | and so on...

Datarow (row3 to row X) where on column E is the name and F to AD presenting the weeknumbers:
ROW 3 :John | 1 | 5 | 15 | 1 | ...


Now, on Sheet 2, I have the weeknumbers below eachother in Column A:

SHEET 2
Week 1

Week 2

....

What I need is to put the name in the right week with the right actions (insert rows based on how many 1's, 2's etc.)... So, if John has actions in week 1, his name has to be under Week 1, if there are two 1's in the range F to AD, there has to be 2 rows inserted with the name of the actions:

SHEET 2
Week 1
Name | Actionname
John | Action 1
Action 4
etc..

Has somebody any idea to do this?
Don't hasitate to ask any questions..

Thanks in advance!
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Sort by date Sort by votes
Try this;-
NB:- The results are in sheet2 columns "A & B".
NB:- The results will Overwrite data in those columns and replace that data with only the Results from Sheet1, for weeks that have "Actions"
Code: 
[COLOR="Navy"]Sub[/COLOR] MG12Feb10
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic         [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Ac          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] k           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] p           [COLOR="Navy"]As[/COLOR] Variant, Sp [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Wk [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("C3", .Range("C" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
     [COLOR="Navy"]For[/COLOR] Ac = 1 To 52
        [COLOR="Navy"]If[/COLOR] Dn.Offset(, Ac).Value <> "" [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Offset(, Ac).Value) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Dn.Offset(, Ac).Value) = CreateObject("Scripting.Dictionary")
            [COLOR="Navy"]End[/COLOR] If
        
            [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Offset(, Ac).Value).exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                Dic(Dn.Offset(, Ac).Value).Add (Dn.Value), Rng(1).Offset(-1, Ac).Value
            [COLOR="Navy"]Else[/COLOR]
                Dic(Dn.Offset(, Ac).Value).Item(Dn.Value) = Dic(Dn.Offset(, Ac).Value).Item(Dn.Value) _
                & ", " & Rng(1).Offset(-1, Ac).Value
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Next[/COLOR] Dn
   
   
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
 .Range("A:B").ClearContents
[COLOR="Navy"]For[/COLOR] Wk = 1 To 52
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
       [COLOR="Navy"]If[/COLOR] Val(k) = Wk [COLOR="Navy"]Then[/COLOR]
         c = c + 1
        .Cells(c, 1) = "Week " & k
         c = c + 1
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k)
                .Cells(c, 1) = p
                Sp = Split(Dic(k).Item(p), ", ")
                    [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
                        .Cells(c, 2) = Sp(n)
                        c = c + 1
                    [COLOR="Navy"]Next[/COLOR] n
            [COLOR="Navy"]Next[/COLOR] p
      [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]Next[/COLOR] Wk
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
At first glance, you used a button, is there a possibility to do it without button when values change?
First, I'm gonna have a look! Thanks for your input!! :)
 
Upvote 0
Try this:-
This code will run when you alter any number (Relating to weeks) in your data Columns "D to BC"
This code needs to be placed in the "Worksheet Module" for sheet1

To load code:-
Copy code
Right click sheet1 tab, Select "View Code", code window appears.
Paste Code into code window.
Close "Code Window"
'####
To run code Change/Enter any number in Columns "D to BC", click "Enter"
Sheet2 should be updated.
Code: 
Private [COLOR="Navy"]Sub[/COLOR] Worksheet_Change(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic         [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Ac          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] k           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] p           [COLOR="Navy"]As[/COLOR] Variant, Sp [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Wk [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("C3", .Range("C" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] nRng = Rng.Offset(, 1).Resize(, 52)
[COLOR="Navy"]If[/COLOR] Not Intersect(nRng, Target) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
     [COLOR="Navy"]For[/COLOR] Ac = 1 To 52
        [COLOR="Navy"]If[/COLOR] Dn.Offset(, Ac).Value <> "" [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Offset(, Ac).Value) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Dn.Offset(, Ac).Value) = CreateObject("Scripting.Dictionary")
            [COLOR="Navy"]End[/COLOR] If
        
            [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Offset(, Ac).Value).exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                Dic(Dn.Offset(, Ac).Value).Add (Dn.Value), Rng(1).Offset(-1, Ac).Value
            [COLOR="Navy"]Else[/COLOR]
                Dic(Dn.Offset(, Ac).Value).Item(Dn.Value) = Dic(Dn.Offset(, Ac).Value).Item(Dn.Value) _
                & ", " & Rng(1).Offset(-1, Ac).Value
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Next[/COLOR] Dn
   
   
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
 .Range("A:B").ClearContents
[COLOR="Navy"]For[/COLOR] Wk = 1 To 52
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
       [COLOR="Navy"]If[/COLOR] Val(k) = Wk [COLOR="Navy"]Then[/COLOR]
         c = c + 1
        .Cells(c, 1) = "Week " & k
         c = c + 1
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k)
                .Cells(c, 1) = p
                Sp = Split(Dic(k).Item(p), ", ")
                    [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
                        .Cells(c, 2) = Sp(n)
                        c = c + 1
                    [COLOR="Navy"]Next[/COLOR] n
            [COLOR="Navy"]Next[/COLOR] p
      [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]Next[/COLOR] Wk
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Solved
VBA to Move Rows Based on Status in Excel
Replies
3
Views
479
Alex Blakenburg
A
D
  • Solved
Using Vlookup, If statements??
Replies
3
Views
215
Dprobasco
D
Smerdis13
  • Question Question
VBA to Get Output by check relations from Input
Replies
2
Views
304
Smerdis13
Smerdis13
C
  • Question Question
Searching using TextBox and ListBox
Replies
1
Views
230
campbell1093
C
T
  • Question Question
Copy and paste range of data to next available row on different sheet
2 3
Replies
22
Views
1K
Trae1170
T

Forum statistics

Threads
1,223,885
Messages
6,175,178
Members
452,615
Latest member
bogeys2birdies

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