希望你的brainiacs可以帮助我，因为我显然达到了编程能力的极限。
我正在寻找一种方法来编写一个复制另一个VBA Sub的VBA子程序，但是替换名称和另一个输入。案例详情如下：
我正在尝试为组织构建一个Excel模板，这将允许用户向/从Access数据库（.accdb）输入/导出数据，因为最终用户不愿意使用真实数据库（而不是excel）列表）显然在于他们无法从Excel中提取/提交数据，他们可以轻松地处理数据。
挑战在于，不知道如何链接到Access的用户肯定对VBA代码一无所知。因此，我创建了一个工作表，用户使用文件路径，表，密码，设置过滤器，定义复制/插入数据集的位置，导入字段等来从中选择数据库。然后宏处理其余部分。
但是，我想创建一个允许用户创建其他数据库链接的宏。就像现在一样，这将要求用户打开VBE并复制两个宏并更改一行代码......但这是一个灾难的处方。那么如何在工作表中添加一个按钮来复制我编写的代码并重命名宏？
......我正在考虑是否使用某个功能，但无法理解它应该如何工作。
有意义吗？任何想法/经验？我有没有考虑过完全不同的方式？
我非常感谢你的投入 - 即使事实证明这是不可能的。
编辑： Macro Man，你问代码 - 由于所有的用户输入字段，它相当长，所以我试图为你保存Guys，因为代码本身工作正常......
Sub GetData1()
' Click on Tools, References and select
' the Microsoft ActiveX Data Objects 2.0 Library
Dim DBFullName As String
Dim Connect As String, Source As String
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
Dim Col As Integer
Dim DBInfoLocation As Range
Dim PW As String
Dim WSforData As String
Dim CellforData As String
Dim FieldList As Integer
'******************************
'Enter location for Database conectivity details below:
'******************************
Set DBInfoLocation = ActiveWorkbook.Sheets("DBLinks").Range("C15:I21")
FieldList = ActiveWorkbook.Sheets("DBLinks").Range("P1").Value
'******************************
' Define data location
WSforData = DBInfoLocation.Rows(4).Columns(1).Value
CellforData = DBInfoLocation.Rows(5).Columns(1).Value
'Set filters
Dim FilField1, FilField2, FilFieldA, FilFieldB, FilFieldC, FilFieldD, FilFieldE, FilOperator1, FilOperator2, FilOperatorA, FilOperatorB, FilOperatorC, FilOperatorD, FilOperatorE, FilAdMth1, FilAdMthA, FilAdMthB, FilAdMthC, FilAdMthD As String
Dim Filtxt1, Filtxt2, FiltxtA, FiltxtB, FiltxtC, FiltxtD, FiltxtE As String
Dim ExtFld1, ExtFld2, ExtFld3, ExtFld4, ExtFld5, ExtFld6, ExtFld7, ExtFld As String
Dim FilCnt, FilCntA As Integer
Dim FilVar1 As String
'Set DB field names
FilField1 = DBInfoLocation.Rows(1).Columns(5).Value
FilField2 = DBInfoLocation.Rows(2).Columns(5).Value
FilFieldA = DBInfoLocation.Rows(3).Columns(5).Value
FilFieldB = DBInfoLocation.Rows(4).Columns(5).Value
FilFieldC = DBInfoLocation.Rows(5).Columns(5).Value
FilFieldD = DBInfoLocation.Rows(6).Columns(5).Value
FilFieldE = DBInfoLocation.Rows(7).Columns(5).Value
'Set filter operators
FilOperator1 = DBInfoLocation.Rows(1).Columns(6).Value
FilOperator2 = DBInfoLocation.Rows(2).Columns(6).Value
FilOperatorA = DBInfoLocation.Rows(3).Columns(6).Value
FilOperatorB = DBInfoLocation.Rows(4).Columns(6).Value
FilOperatorC = DBInfoLocation.Rows(5).Columns(6).Value
FilOperatorD = DBInfoLocation.Rows(6).Columns(6).Value
FilOperatorE = DBInfoLocation.Rows(7).Columns(6).Value
'Run through criteria to find VarType(FilCrit1) (the Dimension data type) for the criteria field and set the appropriate data type for the filter
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(1).Columns(7).Value), CDbl(FilCrit1), IIf((DBInfoLocation.Rows(1).Columns(7).Value = "True" Or DBInfoLocation.Rows(1).Columns(7).Value = "False"), CBool(FilCrit1), IIf(IsDate(DBInfoLocation.Rows(1).Columns(7).Value), CDate(FilCrit1), CStr(FilCrit1))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(2).Columns(7).Value), CDbl(FilCrit2), IIf((DBInfoLocation.Rows(2).Columns(7).Value = "True" Or DBInfoLocation.Rows(2).Columns(7).Value = "False"), CBool(FilCrit2), IIf(IsDate(DBInfoLocation.Rows(2).Columns(7).Value), CDate(FilCrit2), CStr(FilCrit2))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(3).Columns(7).Value), CDbl(FilCrit3), IIf((DBInfoLocation.Rows(3).Columns(7).Value = "True" Or DBInfoLocation.Rows(3).Columns(7).Value = "False"), CBool(FilCrit3), IIf(IsDate(DBInfoLocation.Rows(3).Columns(7).Value), CDate(FilCrit3), CStr(FilCrit3))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(4).Columns(7).Value), CDbl(FilCrit4), IIf((DBInfoLocation.Rows(4).Columns(7).Value = "True" Or DBInfoLocation.Rows(4).Columns(7).Value = "False"), CBool(FilCrit4), IIf(IsDate(DBInfoLocation.Rows(4).Columns(7).Value), CDate(FilCrit4), CStr(FilCrit4))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(5).Columns(7).Value), CDbl(FilCrit5), IIf((DBInfoLocation.Rows(5).Columns(7).Value = "True" Or DBInfoLocation.Rows(5).Columns(7).Value = "False"), CBool(FilCrit5), IIf(IsDate(DBInfoLocation.Rows(5).Columns(7).Value), CDate(FilCrit5), CStr(FilCrit5))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(6).Columns(7).Value), CDbl(FilCrit6), IIf((DBInfoLocation.Rows(6).Columns(7).Value = "True" Or DBInfoLocation.Rows(6).Columns(7).Value = "False"), CBool(FilCrit6), IIf(IsDate(DBInfoLocation.Rows(6).Columns(7).Value), CDate(FilCrit6), CStr(FilCrit6))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(7).Columns(7).Value), CDbl(FilCrit7), IIf((DBInfoLocation.Rows(7).Columns(7).Value = "True" Or DBInfoLocation.Rows(7).Columns(7).Value = "False"), CBool(FilCrit7), IIf(IsDate(DBInfoLocation.Rows(7).Columns(7).Value), CDate(FilCrit7), CStr(FilCrit7))))
'Set Filter criteria
FilCrit1 = DBInfoLocation.Rows(1).Columns(7).Value
FilCrit2 = DBInfoLocation.Rows(2).Columns(7).Value
FilCrit3 = DBInfoLocation.Rows(3).Columns(7).Value
FilCrit4 = DBInfoLocation.Rows(4).Columns(7).Value
FilCrit5 = DBInfoLocation.Rows(5).Columns(7).Value
FilCrit6 = DBInfoLocation.Rows(6).Columns(7).Value
FilCrit7 = DBInfoLocation.Rows(7).Columns(7).Value
'Set additional filter-method
FilAdMth1 = DBInfoLocation.Rows(1).Columns(8).Value
FilAdMthA = DBInfoLocation.Rows(3).Columns(8).Value
FilAdMthB = DBInfoLocation.Rows(4).Columns(8).Value
FilAdMthC = DBInfoLocation.Rows(5).Columns(8).Value
FilAdMthD = DBInfoLocation.Rows(6).Columns(8).Value
'Set which fields to extract
ExtFld1 = DBInfoLocation.Rows(1).Columns(9).Value
ExtFld2 = DBInfoLocation.Rows(2).Columns(9).Value
ExtFld3 = DBInfoLocation.Rows(3).Columns(9).Value
ExtFld4 = DBInfoLocation.Rows(4).Columns(9).Value
ExtFld5 = DBInfoLocation.Rows(5).Columns(9).Value
ExtFld6 = DBInfoLocation.Rows(6).Columns(9).Value
ExtFld7 = DBInfoLocation.Rows(7).Columns(9).Value
'Filter on query
'Only criteria of value type string should have single quotation marks around them
FilCnt = 0
If FilField1 <> "" Then
If VarType(FilCrit1) = vbString Then
Filtxt1 = " WHERE [" & FilField1 & "] " & FilOperator1 & " '" & FilCrit1 & "'"
Else
Filtxt1 = " WHERE [" & FilField1 & "] " & FilOperator1 & " " & FilCrit1
End If
FilCnt = 1
End If
If FilField2 <> "" And FilCnt = 1 Then
If VarType(FilCrit2) = vbString Then
Filtxt2 = " " & FilAdMth1 & " [" & FilField2 & "] " & FilOperator2 & " '" & FilCrit2 & "'"
Else
Filtxt2 = " " & FilAdMth1 & " [" & FilField2 & "] " & FilOperator2 & " " & FilCrit2
End If
FilCnt = 2
End If
'Filter on Dataset
FilCntA = 0
If FilFieldA <> "" Then
If VarType(FilCrit3) = vbString Then
FiltxtA = FilFieldA & " " & FilOperatorA & " '" & FilCrit3 & "'"
Else
FiltxtA = FilFieldA & " " & FilOperatorA & " " & FilCrit3
End If
FilCntA = 1
End If
If FilFieldB <> "" And FilCntA = 1 Then
If VarType(FilCrit4) = vbString Then
FiltxtB = " " & FilAdMthA & " " & FilFieldB & " " & FilOperatorB & " '" & FilCrit4 & "'"
Else
FiltxtB = " " & FilAdMthA & " " & FilFieldB & " " & FilOperatorB & " " & FilCrit4
End If
FilCntA = 2
End If
If FilFieldC <> "" And FilCntA = 2 Then
If VarType(FilCrit5) = vbString Then
FiltxtC = " " & FilAdMthB & " " & FilFieldC & " " & FilOperatorC & " '" & FilCrit5 & "'"
Else
FiltxtC = " " & FilAdMthB & " " & FilFieldC & " " & FilOperatorC & " " & FilCrit5
End If
FilCntA = 3
End If
If FilFieldD <> "" And FilCntA = 3 Then
If VarType(FilCrit6) = vbString Then
FiltxtD = " " & FilAdMthC & " " & FilFieldD & " " & FilOperatorD & " '" & FilCrit6 & "'"
Else
FiltxtD = " " & FilAdMthC & " " & FilFieldD & " " & FilOperatorD & " " & FilCrit6
End If
FilCntA = 4
End If
If FilFieldE <> "" And FilCntA = 4 Then
If VarType(FilCrit7) = vbString Then
FiltxtE = " " & FilAdMthD & " " & FilFieldE & " " & FilOperatorE & " '" & FilCrit7 & "'"
Else
FiltxtE = " " & FilAdMthD & " " & FilFieldE & " " & FilOperatorE & " " & FilCrit7
End If
FilCntA = 5
End If
' Select Fields to Extract
ExtFld = "*"
If ExtFld1 <> "" Then
ExtFld = "[" & ExtFld1 & "]"
End If
If ExtFld2 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "]"
End If
If ExtFld3 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "]"
End If
If ExtFld4 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "],[" & ExtFld4 & "]"
End If
If ExtFld5 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "],[" & ExtFld4 & "],[" & ExtFld5 & "]"
End If
If ExtFld6 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "],[" & ExtFld4 & "],[" & ExtFld5 & "],[" & ExtFld6 & "]"
End If
If ExtFld7 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "],[" & ExtFld4 & "],[" & ExtFld5 & "],[" & ExtFld6 & "],[" & ExtFld7 & "]"
End If
' Database path info
PW = DBInfoLocation.Rows(3).Columns(1).Value
' Your path will be different
DBFullName = DBInfoLocation.Rows(1).Columns(1).Value
DBTable = DBInfoLocation.Rows(2).Columns(1).Value
' Open the connection
Set Connection = New ADODB.Connection
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;"
Connect = Connect & "Data Source=" & DBFullName & ";Jet OLEDB:Database Password=" & PW & ";"
Connection.Open ConnectionString:=Connect
' Create RecordSet & Define data to extract
Set Recordset = New ADODB.Recordset
With Recordset
'Get All Field Names by opening the DB, extracting a recordset, entering the field names and closing the dataset
Source = DBTable
.Open Source:=Source, ActiveConnection:=Connection
For ColH = 0 To Recordset.Fields.Count - 1
ActiveWorkbook.Worksheets("DBLinks").Range("A1").Offset(ColH + 3, FieldList - 1).Cells.Clear
ActiveWorkbook.Worksheets("DBLinks").Range("A1").Offset(ColH + 3, FieldList - 1).Value = Recordset.Fields(ColH).Name
ActiveWorkbook.Worksheets("RangeNames").Range("A1").Offset(ColH + 2, (DBInfoLocation.Rows(1).Columns(2).Value) - 1).Cells.Clear
ActiveWorkbook.Worksheets("RangeNames").Range("A1").Offset(ColH + 2, (DBInfoLocation.Rows(1).Columns(2).Value) - 1).Value = Recordset.Fields(ColH).Name
Next
Set Recordset = Nothing
End With
' Get the recordset, but only extract the field names of those defined in the spreadsheet.
' If no fields have been selected, all fields will be extracted.
Set Connection = New ADODB.Connection
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;"
Connect = Connect & "Data Source=" & DBFullName & ";Jet OLEDB:Database Password=" & PW & ";"
Connection.Open ConnectionString:=Connect
Set Recordset = New ADODB.Recordset
With Recordset
If FilCnt = 0 Then 'No filter
Source = "SELECT " & ExtFld & " FROM " & DBTable
End If
' Filter Data if selected
If FilCnt = 1 Then
Source = "SELECT " & ExtFld & " FROM " & DBTable & Filtxt1
End If
If FilCnt = 2 Then
Source = "SELECT " & ExtFld & " FROM " & DBTable & Filtxt1 & Filtxt2
End If
.Open Source:=Source, ActiveConnection:=Connection
If FilCntA = 1 Then
Recordset.Filter = FiltxtA
End If
If FilCntA = 2 Then
Recordset.Filter = FiltxtA & FiltxtB
End If
If FilCntA = 3 Then
Recordset.Filter = FiltxtA & FiltxtB & FiltxtC
End If
If FilCntA = 4 Then
Recordset.Filter = FiltxtA & FiltxtB & FiltxtC & FiltxtD
End If
If FilCntA = 5 Then
Recordset.Filter = FiltxtA & FiltxtB & FiltxtC & FiltxtD & FiltxtE
End If
'Debug.Print Recordset.Filter
' Clear data
For Col = 0 To Recordset.Fields.Count - 1
If WSforData <> "" Then
ActiveWorkbook.Worksheets(WSforData).Range(CellforData).Offset(0, Col).EntireColumn.Clear
End If
'ActiveWorkbook.Worksheets("DBLinks").Range("A1").Offset(Col + 3, FieldList - 1).Cells.Clear
Next
' Write field names
For Col = 0 To Recordset.Fields.Count - 1
If WSforData <> "" Then
ActiveWorkbook.Worksheets(WSforData).Range(CellforData).Offset(0, Col).Value = Recordset.Fields(Col).Name
End If
Next
' Write recordset
If WSforData <> "" Then
ActiveWorkbook.Worksheets(WSforData).Range(CellforData).Offset(1, 0).CopyFromRecordset Recordset
ActiveWorkbook.Worksheets(WSforData).Columns.AutoFit
End If
End With
' Clear recordset and close connection
Set Recordset = Nothing
Connection.Close
Set Connection = Nothing
End Sub
可能还需要这段“DBLinks”工作表才能完全理解代码： DBLinks user input area for database connectivity
SOLUTION：
我按照建议去研究复制宏的VBProject.VBComponents。我创建了一个简单的表单，它要求用于宏的名称，其余的输入来自相对引用。我将免费为您提供我的长期和不太优雅的代码的完整副本，但代码的基本要素是：
如果其他人可以从我的经验中受益：在表单上的命令按钮的Click-action中：
Private Sub cmdCreateDB_Click()
'Go to Tools, References and add: Microsoft Visual Basic for Applications Extensibility 5.3
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Const DQUOTE = """" ' one " character
Set VBProj = ActiveWorkbook.VBProject
Set VBComp = VBProj.VBComponents("Module1")
Set CodeMod = VBComp.CodeModule
Dim txtDBLinkName As String
txtDBLinkName = Me.txtDBName
With CodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, " Sub " & txtDBLinkName & "()"
LineNum = LineNum + 1
.InsertLines LineNum, " ' Click on Tools, References and select"
LineNum = LineNum + 1
.InsertLines LineNum, " ' the Microsoft ActiveX Data Objects 2.0 Library"
' And then it goes on forever through all the lines of the original code...
' just remember to replace all double quotations with(Without Square brackets):
' [" & DQUOTE & "]
'And it ends up with:
LineNum = LineNum + 1
.InsertLines LineNum, " Set Recordset = Nothing"
LineNum = LineNum + 1
.InsertLines LineNum, " Connection.Close"
LineNum = LineNum + 1
.InsertLines LineNum, " Set Connection = Nothing"
LineNum = LineNum + 1
.InsertLines LineNum, " End Sub"
End With
Unload Me
End Sub
谢谢大家的帮助。 - 尤其是@findwindow提出解决方案的途径。
答案 0 :(得分：0)
为了完成，以下是如何在没有metaprogramming的情况下解决这个问题。
归结为“做同样的事情 - 但是......”的问题通常可以通过使程序尽可能通用来解决。所有特定于单个用例的数据都应以清晰的方式从上面传递下来，从而允许重用该程序。
让我们看一个如何实现这一点的示例，以便从一个或多个不同大小的范围生成查询字符串。
第一步是对属于Filter概念的所有数据进行分组。由于VBA没有对象文字，我们可以使用Array，Collection或Type代替Filter。
生成查询字符串需要区分 QueryFilters 和 RecordFilters 。查看代码，这两个变体足够相似，可以通过单个Type中的简单布尔来处理。
Option Explicit
Private Type Filter
Field As String
Operator As String
Criteria As Variant
AdditionalMethod As String
ExtractedFields As String
IsQueryFilter As Boolean
FilterString As String
End Type
现在我们可以使用单个变量，而不是跟踪多个变量来表示单个概念。
可以使用范围生成过滤器的一种方法。
' Generates a Filter from a given Range of input data.
Private Function GenerateFilter(ByRef source As Range) As Filter
With GenerateFilter
.Field = CStr(source)
.Operator = CStr(source.Offset(0, 1))
.Criteria = source.Offset(0, 2)
.AdditionalMethod = CStr(source.Offset(0, 3))
.ExtractedFields = CStr(source.Offset(0, 4))
.IsQueryFilter = CBool(source.Offset(0, 5))
.FilterString = GenerateFilterString(GenerateFilter)
End With
End Function
正如单个概念可以声明为Type一样，一组东西可以声明为Array（或Collection，Dictionary，...）。这很有用，因为它允许我们将逻辑与特定范围分离。
' Generates a Filter for each row of a given Range of input data.
Private Function GenerateFilters(ByRef source As Range) As Filter()
Dim filters() As Filter
Dim filterRow As Range
Dim i As Long
ReDim filters(0 To source.Rows.Count)
i = 0
For Each filterRow In source.Rows
filters(i) = GenerateFilter(filterRow)
i = i + 1
Next
GenerateFilters = filters()
End Function
我们现在有一个可以从给定范围返回过滤器数组的函数 - 并且，只要列按正确的顺序排列，代码就可以适用于任何范围。
将所有数据放在方便的包中，组装FilterString很容易。
' Generates a FilterString for a given Filter.
Private Function GenerateFilterString(ByRef aFilter As Filter) As String
Dim temp As String
temp = " "
With aFilter
If .AdditionalMethod <> "" Then temp = temp & .AdditionalMethod & " "
If .IsQueryFilter Then
temp = temp & "[" & .Field & "]"
Else
temp = temp & .Field
End If
temp = temp & " " & .Operator & " "
If VarType(.Criteria) = vbString Then
temp = temp & "'" & .Criteria & "'"
Else
temp = temp & .Criteria
End If
End With
GenerateFilterString = temp
End Function
然后可以将数据合并到可以在查询中使用的字符串，而不管指定范围中是否存在多少类型的过滤器。
' Merges the FilterStrings of Filters that have IsQueryString set as True.
Private Function MergeQueryFilterStrings(ByRef filters() As Filter) As String
Dim temp As String
Dim i As Long
temp = " WHERE"
For i = 0 To UBound(filters)
If filters(i).IsQueryFilter Then temp = temp & filters(i).FilterString
Next
MergeQueryFilterStrings = temp
End Function
' Merges the FilterStrings of Filters that have IsQueryString set as False.
Private Function MergeRecordFilterStrings(ByRef filters() As Filter) As String
Dim temp As String
Dim i As Long
For i = 0 To UBound(filters)
If Not filters(i).IsQueryFilter Then _
temp = temp & filters(i).FilterString
Next
MergeRecordFilterStrings = temp
End Function
' Merges the ExtractedFields of all Filters.
Private Function MergeExtractedFields(ByRef filters() As Filter) As String
Dim temp As String
Dim i As Long
temp = ""
For i = 0 To UBound(filters)
If filters(i).ExtractedFields <> "" Then _
temp = temp & "[" & filters(i).ExtractedFields & "],"
Next
If temp = "" Then
temp = "*"
Else
temp = Left(temp, Len(temp) - 1) ' Remove dangling comma.
End If
MergeExtractedFields = temp
End Function
完成所有这些后，我们最终可以插入一个Range并获取生成的字符串。改变filterRange或从多个范围生成过滤器将是微不足道的。
Public Sub TestStringGeneration()
Dim filters() As Filter
Dim filterRange As Range
Set filterRange = Range("A1:A10")
filters = GenerateFilters(filterRange)
Debug.Print MergeQueryFilterStrings(filters)
Debug.Print MergeRecordFilterStrings(filters)
Debug.Print MergeExtractedFields(filters)
End Sub
<强> TL; DR