Autopopulate macro, needs to searrch for appropriate section to autopopulate

[Butcher1]

I have a previous macro that autopopulates based off of a data validation list selection. What I would like to happen is when I make a selection in the Training Plan sheet, cell N172, the macro would clear the contents of Training Plan A171:B182. Then go to the templates page, search in the first row for the same text that was selected in Training Plan N172. When it finds it, select the 12 cells below it and the 12 cells to the right of those cells, and copy and pastes it to Training Plan A171:B182.

For example, if "Another Name" was selected in Training Plan N172, the macro would find "Another Name" in Templates E1 and then copy and paste Templates E2:F13 into Training Plan A171:B182.

I have used the term copy and paste, however it would be great if it didn't actually utilize the clipboard as occasionally I get errors with macros that do use the clipboard.

I can not use set ranges to copy and paste from on the Templates sheet. Right now there are 3, but there will be more added as time goes on and I don't want to have to rework the macro every time one is added.

I will have to expand this out to work based off of Training Plan N172:N183. I am not asking someone to write the whole thing, but I may have questions on how to expand it out.

Thanks in advance. I hope the tone of my post doesn't sound demanding.

[JOHN H. DAVIS]

Maybe?

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [N172]) Is Nothing Then
    Select Case Target.Value
        Case Is = "1st Template Name"
            Range("A171:B183").Value = Sheets("Templates").Range("C1:D13").Value
        Case Is = "Another Name"
            Range("A171:B183").Value = Sheets("Templates").Range("E1:F13").Value
        Case Is = "Yet Another"
            Range("A171:B183").Value = Sheets("Templates").Range("G1:H13").Value
    End Select
End If
End Sub

[simarui]

this oughta get you started. as for expanding i'd suggest putting a label next to each of your range N172:N183 and then using a similar find structure to look for that label in column A.

let me know if you need any help with that.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim LR As Long
Dim LC As Long
Dim Templates As Worksheet
Dim TPlan As Worksheet
Dim searchrange As Range
Dim findcells As Range
Set Templates = Sheets("Templates")
Set TPlan = Sheets("Training Plan")

    If Not Intersect(Target, TPlan.Range("N172:N183")) Is Nothing Then
    LC = Templates.Cells(1, Columns.Count).End(xlToLeft).Column
    Set searchrange = Templates.Range("$C$1:" & Cells(1, LC).Address)
    Set findcells = searchrange.Find(Target.Value)
        If Not findcells Is Nothing Then
        Templates.Range(findcells.Offset(1, 0).Address & ":" & findcells.Offset(13, 1).Address).Copy TPlan.Range("A171")
        End If
    End If
End Sub

[Butcher1]

Maybe?

This wouldn't work for me since the macro would need reworked every time I created a new template.

let me know if you need any help with that.

It works for me but I am completely unable to expand it. Right now any cell change in Training Plan N172:N183 is manipulating Training Plan A171:B182. Here is the list of cell and the corresponding range it should manipulate.
N172 manipulates A171:B182
N173 manipulates A185:B196
N174 manipulates A201:B212
N175 manipulates A215:B226
N176 manipulates A231:B242
N177 manipulates A245:B256
N178 manipulates A261:B272
N179 manipulates A275:B286
N180 manipulates A291:B302
N181 manipulates A305:B316
N182 manipulates A321:B332
N183 manipulates A335:B346

[jaslake]

Hi Butcher1

Will there be more?

Here is the list of cell and the corresponding range it should manipulate.
N172 manipulates A171:B182
N173 manipulates A185:B196
N174 manipulates A201:B212
N175 manipulates A215:B226
N176 manipulates A231:B242
N177 manipulates A245:B256
N178 manipulates A261:B272
N179 manipulates A275:B286
N180 manipulates A291:B302
N181 manipulates A305:B316
N182 manipulates A321:B332
N183 manipulates A335:B346

[jaslake]

Hi Butcher1

See if this works for you...place the Code in Training Plan Module

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim ws           As Worksheet
   Dim myCol        As Long
   Dim sRng         As Range

   Set ws = Sheets("Templates")

   If Not Intersect(Target, Range("N172:N183")) Is Nothing Then

      myCol = WorksheetFunction.Match(Target.Value, ws.Rows("1:1"), 0)
      Set sRng = ws.Cells(2, myCol).Resize(12, 2)

      Application.EnableEvents = False
      Select Case Target.Row
      Case 172
         Range(Cells(171, 1), Cells(182, 2)).Value = sRng.Value
      Case 173
         Range(Cells(185, 1), Cells(196, 2)).Value = sRng.Value
      Case 174
         Range(Cells(201, 1), Cells(212, 2)).Value = sRng.Value
      Case 175
         Range(Cells(215, 1), Cells(226, 2)).Value = sRng.Value
      Case 176
         'etc
      Case 177
         'etc
      Case 178
         'etc
      Case 179
         'etc
      Case 180
         'etc
      Case 181
         'etc
      Case 182
         'etc
      Case 183

      End Select
   Else
      Exit Sub

   End If
   Application.EnableEvents = True
End Sub

[Butcher1]

Hi Butcher1

See if this works for you...place the Code in Training Plan Module

Thank you, it worked perfectly!

[jaslake]

You're welcome...glad I could help. Thanks for the Rep.

[simarui]

sounds like this is solved, but i finally got this to work and wanted to share:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim LR As Long
Dim LC As Long
Dim Templates As Worksheet
Dim TPlan As Worksheet
Dim searchrange As Range
Dim findcells As Range
Dim inputrange As Range
Dim outputrange As Range
Set Templates = Sheets("Templates")
Set TPlan = Sheets("Training Plan")

    If Not Intersect(Target, TPlan.Range("N172:N183")) Is Nothing Then
    LC = Templates.Cells(1, Columns.Count).End(xlToLeft).Column
    LR = TPlan.Range("A" & Rows.Count).End(xlUp).Row
    Set searchrange = Templates.Range("$C$1:" & Cells(1, LC).Address)
    Set findcells = searchrange.Find(Target.Value)
        If Not findcells Is Nothing Then
        Set inputrange = Templates.Range(findcells.Offset(1, 0).Address & ":" & findcells.Offset(13, 1).Address)
        End If
    Set findcells = TPlan.Range("A169:A" & LR).Find(Target.Offset(0, 1).Value)
        If Not findcells Is Nothing Then
        Set outputrange = TPlan.Range("A169:A" & LR).Find(Target.Offset(0, 1).Value).Offset(1)
        End If
    inputrange.Copy outputrange
          
    End If
End Sub

i think it's a little bit easier to expand in the future - just need to make sure you write Week ## in column O and in column A, and change your intersect range to include the new row (i.e. if not intersect(target, TPlan.Range(N172:N184) is nothing then...)