Очистка кода VBA до ссылочного кода вместо его дублирования

Я закодировал форму для ввода информации о продукте, которая работает, и хотел бы ее очистить. В настоящее время для каждого подразделения продукта я скопировал и вставил один и тот же код, чтобы взять значения из формы и применить их к правильному листу подразделения. Я хотел бы, чтобы код встречался один раз, а затем ссылался на него в коде для 22 делений. Мне не удалось найти решение этой проблемы, вероятно, потому что я не знаю правильной терминологии.

Вот раздел, который я хотел бы исправить:

Case "DIVISION 21 - FIRE SUPPRESSION"
Set ws = Sheets("Div-21")

LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value


Case "DIVISION 22 - PLUMBING"
Set ws = Sheets("Div-22")

LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value


Case "DIVISION 23 - HEATING VENTILATING AND AIR CONDITIONING"
Set ws = Sheets("Div-23")

LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value


Case "DIVISION 26 - ELECTRICAL"
Set ws = Sheets("Div-26")

LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value


Case "DIVISION 27 - COMMUNICATIONS"
Set ws = Sheets("Div-27")

LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value

Вот что я хотел бы сделать, если это возможно:

[Refrence Code]=

LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value


Case "DIVISION 21 - FIRE SUPPRESSION"
Set ws = Sheets("Div-21")

[Refrence code]


Case "DIVISION 22 - PLUMBING"
Set ws = Sheets("Div-22")

[Refrence code]


Case "DIVISION 23 - HEATING VENTILATING AND AIR CONDITIONING"
Set ws = Sheets("Div-23")

[Refrence code]


Case "DIVISION 26 - ELECTRICAL"
Set ws = Sheets("Div-26")

[Refrence code]


Case "DIVISION 27 - COMMUNICATIONS"
Set ws = Sheets("Div-27")

[Refrence code]

Любая помощь будет оценена. Если возможно, пожалуйста, объясните ясно и подробно, так как я все еще новичок в кодировании VBA и новичок в кодировании в целом.

Всего 2 ответа


Часть, которая изменяется, это ws . Сохраните Select Case и затем переместите повторяющийся блок.

    Case "DIVISION 21 - FIRE SUPPRESSION"
         Set ws = Sheets("Div-21")
    Case "DIVISION 22 - PLUMBING"
         Set ws = Sheets("Div-22")
    Case "DIVISION 22 - PLUMBING"
         Set ws = Sheets("Div-23")
    ...
    Case Else
         ' handle other cases, perhaps `Exit Sub`
End Select

' Now you need only one instance of the repetitive block
' You've got the right `ws` from above.

LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
... and so on

Если вы имеете дело с повторяющимся шаблоном DIVISION - ## - .... , то вы могли бы реорганизовать свой вариант Select Case в отдельную функцию, которая анализирует имя листа, а не перечисляет все возможности, как в настоящее время.


Глядя, чтобы не повторять код это отличная вещь. В этом случае вы можете просто сделать следующее:

Case "DIVISION 21 - FIRE SUPPRESSION"
Set ws = Sheets("Div-21")

Case "DIVISION 22 - PLUMBING"
Set ws = Sheets("Div-22")

End Select

LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value

Но так как вы изучаете, как «обрезать код», я хотел бы также описать вызов подпрограммы с аргументами, например, так.

Sub SheetSelect()

Dim ws as worksheet 

Case "DIVISION 21 - FIRE SUPPRESSION"
Set ws = Sheets("Div-21")
Call DoStuff(ws)

Case "DIVISION 22 - PLUMBING"
Set ws = Sheets("Div-22")
Call DoStuff(ws)

End Select
End Sub

Sub DoStuff(ws As WorkSheet)

LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value

End Sub

Я не знаю, что это за практика / лучшая политика, но я часто помещаю отдельные подпрограммы в отдельные модули, чтобы у меня не было модулей, которые были бы очень длинными. У меня также есть «основной» модуль, который вызывает только каждый сабвуфер, который что-то делает. Это позволяет мне комментировать подпрограммы для отладки и заново вводить их по одному.

Например:

Sub Main_Sub()

Call First_Task

'Call Second_Task ' Comment out "Second Task" for debugging till "First_Task" works as expected, this also allows for future debugging.

End Sub

Есть идеи?

10000