Question

我正在为建筑行业制定一个酒吧弯曲时间表。我是excel vba的新手，我正在尽我所能，但偶然发现了一个我正在努力寻找解决方案的问题。

我正在使用项目中的以下对象;

工作表＆＃34; BBS＆＃34;
工作表＆＃34;形状＆＃34;
Userform＆＃34; BBSForm＆＃34;

我的形状与＃34; Shapes＆＃34;上的文本框组合在一起。工作表。示例形状是＆＃34; L＆＃34;这是一个L形条，有2个尺寸，因此有2个文本框。

当＆＃34; L＆＃34;在用户表单上选择形状并输入文本框尺寸我单击一个按钮，将条目提交到＆＃34; BBS＆＃34;工作表。它复制＆＃34; Lgroup＆＃34;从形状表中将其粘贴到＆＃34; BBS＆＃34;片材。

当我有2个文本框作为粘贴时，问题就出现了，他们更改了名称，我需要知道他们的名字，所以我可以用维度填充它们。

到目前为止我有下面的代码，但L形状不能用作＃34; Forms.TextBox.2＆＃34;不存在，组中的两个文本框都是＆＃34; Forms.TextBox.1＆＃34;。

Sub ShapeSelectCopy()
    Dim CodeSh As String
    CodeSh = BBSForm.TextBoxShp.Value

    Worksheets("BBS").Activate
    Range("A1").End(xlDown).Offset(0, 5).Select
    Dim nextsh As Range
    Set nextsh = Selection

    Select Case CodeSh

    Case "S"

                Sheets("Shapes").Select
                ActiveSheet.Shapes.Range(Array("Group 13")).Select
                Selection.Copy
                Sheets("BBS").Select
                ActiveSheet.Paste
                Dim newname As String
                newname = Sheets("BBS").Range("A1").End(xlDown).Offset(0, 0).Value
                Selection.Name = newname
                    With Selection
                                .Left = nextsh.Left + (nextsh.Width - Selection.Width) / 2
                                .Top = nextsh.Top + (nextsh.Height - Selection.Height) / 2
                    End With

            Dim shpG As Shape, shp As Shape
            Dim objOLE As OLEObject

                Set shpG = ActiveSheet.Shapes(newname)
                For Each shp In shpG.GroupItems
                Set objOLE = shp.OLEFormat.Object

            If objOLE.progID = "Forms.TextBox.1" Then objOLE.Object.Value = BBSForm.TextBoxA.Value
            Next


    Case "L"
            Sheets("Shapes").Select
            ActiveSheet.Shapes.Range(Array("Group 12")).Select
            Selection.Copy
            Sheets("BBS").Select
            ActiveSheet.Paste
            Dim newname As String
            newname = Sheets("BBS").Range("A1").End(xlDown).Offset(0, 0).Value
            Selection.Name = newname
                With Selection
                            .Left = nextsh.Left + (nextsh.Width - Selection.Width) / 2
                            .Top = nextsh.Top + (nextsh.Height - Selection.Height) / 2
                End With

            Dim shpG As Shape, shp As Shape
            Dim objOLE As OLEObject

                Set shpG = ActiveSheet.Shapes(newname)
                For Each shp In shpG.GroupItems
                Set objOLE = shp.OLEFormat.Object

            If objOLE.progID = "Forms.TextBox.1" Then objOLE.Object.Value = BBSForm.TextBoxA.Value
            If objOLE.progID = "Forms.TextBox.2" Then objOLE.Object.Value = BBSForm.TextBoxB.Value

            Next
    End Select
End Sub

非常感谢任何帮助。

Answer 1

在这里考虑一些重复的代码，这是一种方法：

Sub ShapeSelectCopy()

    Dim CodeSh As String
    Dim nextsh As Range
    Dim shtShapes As Worksheet, shtBBS As Worksheet
    Dim shpToCopy As String, val1, val2
    Dim tbCount As Long
    Dim shpG As ShapeRange, shp As Shape, pid

    Set shtShapes = Worksheets("Shapes")
    Set shtBBS = Worksheets("BBS")

    Set nextsh = shtBBS.Range("A1").End(xlDown).Offset(0, 5)

    shpToCopy = ""

    CodeSh = BBSForm.TextBoxShp.Value

    Select Case CodeSh
        Case "S"
            shpToCopy = "Group 13"
            val1 = BBSForm.TextBoxA.Value
            val2 = ""

        Case "L"
            shpToCopy = "Group 12"
            val1 = BBSForm.TextBoxA.Value
            val2 = BBSForm.TextBoxB.Value '<< edit to fix typo
    End Select

    If shpToCopy = "" Then Exit Sub 'exit if no shape to copy

    'copy the shape
    shtShapes.Shapes(shpToCopy).Copy
    shtBBS.Activate
    shtBBS.Paste
    Set shpG = Selection.ShapeRange

    'name and position
    With shpG
        .Name = shtBBS.Range("A1").End(xlDown).Value
        .Left = nextsh.Left + (nextsh.Width - shpG.Width) / 2
        .Top = nextsh.Top + (nextsh.Height - shpG.Height) / 2
    End With

    'populate textbox(es)
    tbCount = 0
    For Each shp In shpG.GroupItems
        On Error Resume Next
        pid = shp.OLEFormat.progID
        On Error GoTo 0
        'Debug.Print ">>>", pid
        If pid = "Forms.TextBox.1" Then
            tbCount = tbCount + 1
            If tbCount = 1 Then shp.OLEFormat.Object.Object.Value = val1
            If tbCount = 2 Then shp.OLEFormat.Object.Object.Value = val2
        End If
    Next shp

End Sub

如何重命名active-x在复制和粘贴到另一个工作表后按形状分组的控件文本框

1 个答案: