Automating Data Population

[hitdave85]

Hello,

I am trying to populate some data by relying on a table I have named Area_Table. Here is what the table looks like:

Unique ID	Area 1	Area 2	Area 3	Area 4	Area 5
1001	Y	N	N	N	Y
1002	Y	N	N	N	N
1003	N	Y	Y	Y	N
1004	Y	Y	Y	Y	N
1005	Y	Y	Y	Y	N

<tbody>
</tbody>

Here is what I am trying to populate by using the Area_Table:

Unique ID	Area	Age
1001	Area 1	20
1001	Area 1	21
1001	Area 1	22
1001	Area 1	23
1001	Area 1	24
1001	Area 1	25
1001	Area 5	20
1001	Area 5	21
1001	Area 5	22
1001	Area 5	23
1001	Area 5	24
1001	Area 5	25
1002	Area 1	20
1002	Area 1	21
1002	Area 1	22
1002	Area 1	23
1002	Area 1	24
1002	Area 1	25
1003	Area 2	20
1003	Area 2	21
1003	Area 2	22
1003	Area 2	23
1003	Area 2	24
1003	Area 2	25

<tbody>
</tbody>

As you can see, for each unique ID in the Area_Table, I want to populate ages 20-25 for all of the 'Y' areas. The 'N' areas are NOT populated. The hope is that a simple click of a button will populate the data for me. I assume since I am relying on a table, that the range will become dynamic, which will allow me to add/remove unique IDs pretty easily. I'm hoping a simple macro can address this problem since I have a lot of data to populate. Any ideas?

Thanks so much for the help!

 

[mumps]

Try this macro. Change the sheet names to suit your needs. The result will be in Sheet2.

Sub Test()
    Application.ScreenUpdating = False
    Dim LastRow As Long, area As Range, lCol As Long, x As Long
    lCol = Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For x = 2 To LastRow
        For Each area In Sheets("Sheet1").Range(Sheets("Sheet1").Cells(x, 2), Sheets("Sheet1").Cells(x, lCol))
            If area = "Y" Then
                With Sheets("Sheet2")
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(6) = Sheets("Sheet1").Cells(x, 1)
                    .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(6) = Sheets("Sheet1").Cells(1, area.Column)
                    With .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0)
                        .Value = 20
                        .AutoFill .Resize(6, 1), xlFillSeries
                    End With
                End With
            End If
        Next area
    Next x
    Application.ScreenUpdating = True
End Sub

 

[hitdave85]

Very cool! What if I want to populate that third column with the following ages (mix of integers and strings):

0-14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64+

<colgroup><col style="mso-width-source:userset;mso-width-alt:3986;width:82pt" width="109"> </colgroup><tbody>
</tbody>

Thanks again for the help!!!

 

[mumps]

Could you post a sample of what the end result will look like?

 

[hitdave85]

1001	Area 1	0-14
1001	Area 1	15
1001	Area 1	16
1001	Area 1	17
1001	Area 1	18
1001	Area 1	19
1001	Area 1	20
1001	Area 1	21
1001	Area 1	22
1001	Area 1	23
1001	Area 1	24
1001	Area 1	25
1001	Area 1	26
1001	Area 1	27
1001	Area 1	28
1001	Area 1	29
1001	Area 1	30
1001	Area 1	31
1001	Area 1	32
1001	Area 1	33
1001	Area 1	34
1001	Area 1	35
1001	Area 1	36
1001	Area 1	37
1001	Area 1	38
1001	Area 1	39
1001	Area 1	40
1001	Area 1	41
1001	Area 1	42
1001	Area 1	43
1001	Area 1	44
1001	Area 1	45
1001	Area 1	46
1001	Area 1	47
1001	Area 1	48
1001	Area 1	49
1001	Area 1	50
1001	Area 1	51
1001	Area 1	52
1001	Area 1	53
1001	Area 1	54
1001	Area 1	55
1001	Area 1	56
1001	Area 1	57
1001	Area 1	58
1001	Area 1	59
1001	Area 1	60
1001	Area 1	61
1001	Area 1	62
1001	Area 1	63
1001	Area 1	64 and over
1001	Area 5	0-14
1001	Area 5	15
1001	Area 5	16
1001	Area 5	17
1001	Area 5	18
1001	Area 5	19
1001	Area 5	20
1001	Area 5	21
1001	Area 5	22
1001	Area 5	23
1001	Area 5	24
1001	Area 5	25
1001	Area 5	26
1001	Area 5	27
1001	Area 5	28
1001	Area 5	29
1001	Area 5	30
1001	Area 5	31
1001	Area 5	32
1001	Area 5	33
1001	Area 5	34
1001	Area 5	35
1001	Area 5	36
1001	Area 5	37
1001	Area 5	38
1001	Area 5	39
1001	Area 5	40
1001	Area 5	41
1001	Area 5	42
1001	Area 5	43
1001	Area 5	44
1001	Area 5	45
1001	Area 5	46
1001	Area 5	47
1001	Area 5	48
1001	Area 5	49
1001	Area 5	50
1001	Area 5	51
1001	Area 5	52
1001	Area 5	53
1001	Area 5	54
1001	Area 5	55
1001	Area 5	56
1001	Area 5	57
1001	Area 5	58
1001	Area 5	59
1001	Area 5	60
1001	Area 5	61
1001	Area 5	62
1001	Area 5	63
1001	Area 5	64 and over
1002	Area 1	0-14
1002	Area 1	15
1002	Area 1	16
1002	Area 1	17
1002	Area 1	18
1002	Area 1	19
1002	Area 1	20
1002	Area 1	21
1002	Area 1	22
1002	Area 1	23
1002	Area 1	24
1002	Area 1	25
1002	Area 1	26
1002	Area 1	27
1002	Area 1	28
1002	Area 1	29
1002	Area 1	30
1002	Area 1	31
1002	Area 1	32
1002	Area 1	33
1002	Area 1	34
1002	Area 1	35
1002	Area 1	36
1002	Area 1	37
1002	Area 1	38
1002	Area 1	39
1002	Area 1	40
1002	Area 1	41
1002	Area 1	42
1002	Area 1	43
1002	Area 1	44
1002	Area 1	45
1002	Area 1	46
1002	Area 1	47
1002	Area 1	48
1002	Area 1	49
1002	Area 1	50
1002	Area 1	51
1002	Area 1	52
1002	Area 1	53
1002	Area 1	54
1002	Area 1	55
1002	Area 1	56
1002	Area 1	57
1002	Area 1	58
1002	Area 1	59
1002	Area 1	60
1002	Area 1	61
1002	Area 1	62
1002	Area 1	63
1002	Area 1	64 and over

<colgroup><col><col><col></colgroup><tbody>
</tbody>

 

[hitdave85]

I also want the results to be pasted starting in cell A15 on Sheet2 if that's possible. Thanks!

 

[mumps]

Try:

Sub Test()
    Application.ScreenUpdating = False
    Dim LastRow As Long, LastRow2 As Long, area As Range, lCol As Long, x As Long
    LastRow2 = 15
    lCol = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For x = 2 To LastRow
        For Each area In Sheets("Sheet1").Range(Sheets("Sheet1").Cells(x, 2), Sheets("Sheet1").Cells(x, lCol))
            If area = "Y" Then
                With Sheets("Sheet2")
                    .Cells(LastRow2, 1).Resize(51) = Sheets("Sheet1").Cells(x, 1)
                    .Cells(LastRow2, 2).Resize(51) = Sheets("Sheet1").Cells(1, area.Column)
                    .Cells(LastRow2, 3) = "0-14"
                    With .Cells(LastRow2 + 1, 3)
                        .Value = 15
                        .AutoFill .Resize(49, 1), xlFillSeries
                    End With
                    .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0) = "64 and over"
                    LastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
                End With
            End If
        Next area
    Next x
    Application.ScreenUpdating = True
End Sub

 

[hitdave85]

Works perfectly! Thanks so much - very impressive.

 

[hitdave85]

I tried to adapt your code by using a named range, but nothing seems to happen when I run the following code. Any thoughts?

Sub Test()
Application.ScreenUpdating = False
Dim LastRow As Long, LastRow2 As Long, area As Range, lCol As Long, x As Long
LastRow2 = 15
lCol = Sheets("Inputs").Range("Plan_IDs").Columns.Count
LastRow = Sheets("Inputs").Range("Plan_IDs").Rows.Count
For x = 2 To LastRow
For Each area In Sheets("Inputs").Range("Plan_IDs").Range(Sheets("Inputs").Range("Plan_IDs").Cells(x, 15), Sheets("Inputs").Range("Plan_IDs").Cells(x, lCol))
If area = "Y" Then
With Worksheets("Rate Development")
.Cells(LastRow2, 1).Resize(51) = Sheets("Inputs").Range("Plan_IDs").Cells(x, 1)
.Cells(LastRow2, 2).Resize(51) = Sheets("Inputs").Range("Plan_IDs").Cells(1, area.Column)
.Cells(LastRow2, 3) = "0-14"
With .Cells(LastRow2 + 1, 3)
.Value = 15
.AutoFill .Resize(49, 1), xlFillSeries
End With
.Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0) = "64 and over"
LastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
End If
Next area
Next x
Application.ScreenUpdating = True
End Sub

 

[mumps]

The macro loops through each row of your data so a named range won't work because you would need a different named range for each row. A named range would be OK if you were looping through only one range but in your case you would need a different named range for each Unique ID.