Excel VBA宏复制宏

Question

解决了。解决办法在底部！

希望你们的智囊团能帮助我，因为我显然已经达到了编程能力的极限。

我正在寻找一种方法来编写一个VBA子，它复制了另一个VBA，但是替换了名称和另一个输入。案件详情如下：

我正试图为该组织构建一个Excel模板，该模板将允许用户将数据导入/导出Access数据库(.accdb)，因为最终用户不愿意使用真正的数据库(而不是Excel列表)，显然是因为他们无法从excel中提取/提交数据，在那里他们能够很好地处理数据。

挑战在于，不知道如何链接到访问的用户，肯定不知道任何关于VBA代码的信息。因此，我创建了一个工作表，用户可以使用文件路径、表、密码、设置过滤器、定义复制/插入数据集的位置、要导入的字段等来选择数据库。

但是，我想要创建一个宏，它允许用户创建其他数据库链接。现在，这将要求用户打开VBE并复制两个宏并更改一行代码.但这是一个灾难的配方。那么，如何在工作表中添加一个按钮来复制我编写的代码并重命名宏呢？

..。我正在考虑是否使用一个函数，但我无法理解它应该如何工作。

说得通吗？有什么想法/经验吗？有没有一种完全不同的方法，我还没有考虑过？

我非常感谢你的意见-即使这是不可能的。

编辑:宏人，你要求的代码-它是相当长的由于所有的用户输入字段，所以我试图为它保存你们，因为代码本身是好的.

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用户输入区域所必需的。

解决方案：

我按照建议查看复制宏的VBProject.VBComponents。我创建了一个简单的表单，它要求宏使用名称，其余的输入来自相对引用。我将留出一份完整的代码，但代码的要旨是：

如果其他人可以从我的经验中受益:在表单上的命令按钮的单击操作中：

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为您找到了解决方案的路径。

Answer 1

为了完成这个任务，下面是在没有元编程.的情况下如何处理这个问题

问题归结为“做同样的事-但是.”通常可以通过使程序尽可能通用来解决。所有特定于单个用例的数据都应该以一种清晰的方式从上面传递下来，从而允许程序被重用。

让我们看看如何实现这个示例，以便从一个或多个不同大小的范围生成查询字符串。

第一步是对属于Filter概念的所有数据进行分组。因为VBA没有对象文本，所以我们可以使用Array、Collection或Type来表示过滤器。

生成查询字符串需要区分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

就像可以将单个概念声明为类型一样，一组事物可以声明为数组(或集合、字典、.)。这是有用的，因为它允许我们将逻辑与特定范围分离开来。

' 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

完成所有这些之后，我们最终可以插入单个范围并取出生成的字符串。更改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；博士

• 将代码拆分成可重用的函数& Subs
• 赞成将数据作为参数发送
• 避免硬编码
• 表示单个概念的组数据
• 在多变量上使用数组或其他数据结构