Excel VBAmacros复制一个macros
解决了。 解决scheme在底部！
希望你能帮助我，因为我明显已经达到了我的编程能力的极限。
我正在寻找一种方法来写一个VBA子复制另一个VBA子，但replace名称和另一个input。 详细情况如下：
我试图为组织创buildExcel模板，这将允许用户从Access数据库（.accdb）导入/导出数据，因为最终用户显然不愿意使用真正的数据库（而不是excel列表）在于他们无法从Excel中提取/提交数据，他们在数据中使用起来很舒服。
所面临的挑战是，那些不知道如何链接到Access的用户，肯定对VBA代码一无所知。 因此，我创build了一个工作表，用户从中select一个数据库，使用文件path，表，密码，设置filter，定义复制/插入数据集的位置，导入的字段等等。
不过，我想创build一个允许用户创build额外数据库链接的macros。 就目前而言，这将需要用户打开VBE并复制两个macros并更改一行代码……但这是一个灾难的秘诀。 那么，如何将一个button添加到工作表中复制已写入的代码并重命名macros呢？
…我正在考虑如果使用一个函数，但不能让我的脑袋周围应该如何工作。
是否有意义？ 任何想法/经验？ 有没有完全不同的方式，我没有考虑？
我真的很感激你的投入 – 即使这是不可能的。
编辑：macros人，你要求的代码 – 这是相当长的，由于所有的用户input字段，所以我试图拯救你的人，因为代码本身工作正常…
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用户input区域的数据库连接
解：
我按照build议去查看复制macros的VBProject.VBComponents。 我创build了一个简单的表单，要求用于macros的名称，其余的input来自相对引用。 我会尽全力为你提供一份完整的，优雅的代码，但代码的基本要素是：
如果其他人可以从我的经验中受益：在窗体上的命令button的点击操作：
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
感谢大家的帮助。 – 特别是您在寻找解决scheme的途径中寻找窗口。
为了完成，这里是如何处理没有元编程 。
归结为“做同样的事情 – 但是…”的问题通常可以通过使程序尽可能通用来解决。 所有针对单个用例的数据都应该从上面以一种明确的方式传递下来，从而允许程序被重用。
我们来看一个如何实现这个例子，以便从一个或多个不同大小的范围中生成查询string。
第一步是对属于Filter概念的所有数据进行分组。 由于VBA没有对象字面值，我们可以使用Array，Collection或Type来表示Filter。
生成查询string需要区分QueryFilters和RecordFilters 。 查看代码，这两个变体足够相似，可以通过一个简单的布尔types来处理。
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
现在我们可以使用一个variables来代替一个概念来跟踪多个variables。
filter的一种生成方式是使用Range。
' 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
就像一个单一的概念可以被声明为一个types一样，一组事物可以被声明为一个数组（或一个集合，字典，…）。 这很有用，因为它可以让我们将逻辑与特定范围分离。
' 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
我们现在有一个函数可以返回给定范围的filter数组，只要列以正确的顺序放置，代码就可以在任何范围内正常工作。
将所有的数据放在一个方便的包中，组装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
然后可以将数据合并为可在查询中使用的string，而不pipe在指定的范围中存在多less种types的filter。
' 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并获取生成的string。 更改filterRange或从多个范围生成filter将是微不足道的。
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
- 将代码拆分为可重复使用的函数和子集
- 赞成发送数据作为参数
- 避免硬编码
- 代表一个概念的数据组
- 在多个variables上使用数组或其他数据结构