VBA - Copy cell contents to create new "sub"

[ewoeckel]

Hi all!

I am not sure if this is possible, but thought I would ask some more fluent folks in VBA. I have a workbook that has "templates" which allows users to load default projects by clicking a button. Probably not the BEST way to do this but an example of this would be:

Sub CustomProj1()

Application.ScreenUpdating = False

Worksheets("Job1").Range("J4").Value = "0"

Worksheets("Job1").Range("B15").Value = "1"
Worksheets("Job1").Range("C15").Value = "8"

Worksheets("Job1").Range("L4").Value = "1"
 
Worksheets("Job1").Range("C17").Value = "1"
Worksheets("Job1").Range("E17").Value = "8"
Worksheets("Job1").Range("D17").Value = "8"
  
Worksheets("Labor").Range("C9").Value = "1"
Worksheets("Labor").Range("C10").Value = "Engineer"
Worksheets("Labor").Range("C11").Value = "8"
 
End Sub

I am curious if someone decides to load their own values into the cells and not use one of my templates, is there a way to "copy" their selections and add it to a new sub / macro and prompt them on what to name it?

Thanks!
E

 

[dmt32]

Hi,
I would suggest rather than hardcode each project in a seperate sub, place all project values in a worksheet (which can be hidden) and give users the ability to choose which project data to load to your templates which can be done with common code like following

Sub CustomProj()
    Dim TemplateRange(1 To 2)   As Range
    Dim wsProjects              As Worksheet
    Dim m                       As Variant, arr As Variant
    Dim ProjectChoice           As Variant
    Dim Default                 As String
    Const Title                 As String = "Enter Project"
    Dim cell                    As Range
    Dim i                       As Integer, r As Integer
    
    With ThisWorkbook
        Set wsProjects = .Worksheets("Projects")
        Set TemplateRange(1) = .Worksheets("Job1").Range("J4,B15,C15,L4,C17,E17,D17,D17")
        Set TemplateRange(2) = .Worksheets("Labor").Range("C9:C11")
    End With
    
    Do
        ProjectChoice = InputBox("Enter Project", Title, Default)
        'cancel pressed
        If StrPtr(ProjectChoice) = 0 Then Exit Sub
        If Len(ProjectChoice) > 0 Then
            m = Application.Match(ProjectChoice, wsProjects.Rows(1), 0)
            If Not IsError(m) Then Exit Do
            Default = "Project Not Found"
        End If
    Loop
    
    
    arr = wsProjects.Cells(2, CLng(m)).Resize(10, 1).Value
    
    For i = 1 To 2
        For Each cell In TemplateRange(i).Cells
            r = r + 1
            cell.Value = arr(r, 1)
        Next cell
        r = 0
    Next i
    
End Sub

This code only retrieves values from existing projects in the table - you would need to develop idea to add new values entered by users.

Dave

02-03-2021.xls
	A	B	C	D	E	F	G	H	I	J	K
1	Proj1	Proj2	Proj3	Proj4	Proj5	Proj6	Proj7	Proj8	Proj9	Proj10	Proj11
2	1	4	7	10	13	16	19	22	25	28	31
3	2	5	8	11	14	17	20	23	26	29	32
4	3	6	9	12	15	18	21	24	27	30	33
5	4	7	10	13	16	19	22	25	28	31	34
6	5	8	11	14	17	20	23	26	29	32	35
7	6	9	12	15	18	21	24	27	30	33	36
8	7	10	13	16	19	22	25	28	31	34	37
9	8	11	14	17	20	23	26	29	32	35	38
10	9	12	15	18	21	24	27	30	33	36	39
11	10	13	16	19	22	25	28	31	34	37	40
Projects

 

[ewoeckel]

Hi,
I would suggest rather than hardcode each project in a seperate sub, place all project values in a worksheet (which can be hidden) and give users the ability to choose which project data to load to your templates which can be done with common code like following

Sub CustomProj()
    Dim TemplateRange(1 To 2)   As Range
    Dim wsProjects              As Worksheet
    Dim m                       As Variant, arr As Variant
    Dim ProjectChoice           As Variant
    Dim Default                 As String
    Const Title                 As String = "Enter Project"
    Dim cell                    As Range
    Dim i                       As Integer, r As Integer
   
    With ThisWorkbook
        Set wsProjects = .Worksheets("Projects")
        Set TemplateRange(1) = .Worksheets("Job1").Range("J4,B15,C15,L4,C17,E17,D17,D17")
        Set TemplateRange(2) = .Worksheets("Labor").Range("C9:C11")
    End With
   
    Do
        ProjectChoice = InputBox("Enter Project", Title, Default)
        'cancel pressed
        If StrPtr(ProjectChoice) = 0 Then Exit Sub
        If Len(ProjectChoice) > 0 Then
            m = Application.Match(ProjectChoice, wsProjects.Rows(1), 0)
            If Not IsError(m) Then Exit Do
            Default = "Project Not Found"
        End If
    Loop
   
   
    arr = wsProjects.Cells(2, CLng(m)).Resize(10, 1).Value
   
    For i = 1 To 2
        For Each cell In TemplateRange(i).Cells
            r = r + 1
            cell.Value = arr(r, 1)
        Next cell
        r = 0
    Next i
   
End Sub

This code only retrieves values from existing projects in the table - you would need to develop idea to add new values entered by users.

Dave

02-03-2021.xls
	A	B	C	D	E	F	G	H	I	J	K
1	Proj1	Proj2	Proj3	Proj4	Proj5	Proj6	Proj7	Proj8	Proj9	Proj10	Proj11
2	1	4	7	10	13	16	19	22	25	28	31
3	2	5	8	11	14	17	20	23	26	29	32
4	3	6	9	12	15	18	21	24	27	30	33
5	4	7	10	13	16	19	22	25	28	31	34
6	5	8	11	14	17	20	23	26	29	32	35
7	6	9	12	15	18	21	24	27	30	33	36
8	7	10	13	16	19	22	25	28	31	34	37
9	8	11	14	17	20	23	26	29	32	35	38
10	9	12	15	18	21	24	27	30	33	36	39
11	10	13	16	19	22	25	28	31	34	37	40
Projects

Ooooooh. Very interesting. I am not 100% sure how the code here works, but I am definietely going to play with this to see if I can get it to work. Thank you Dave!

 

[dmt32]

Ooooooh. Very interesting. I am not 100% sure how the code here works, but I am definietely going to play with this to see if I can get it to work. Thank you Dave!

Its only a suggestion & idea will need developing to meet project need

Set TemplateRange(1) = .Worksheets("Job1").Range("J4,B15,C15,L4,C17,E17,D17,D17")

If not already seen it, you will need to correct my double entry of address D17

Dave