Question

我有一个使用activeX组合框来运行VBA代码的excel工作簿。它适用于大多数PC。

然而，我的一些客户发现，当他们点击组合框时，组合框似乎加倍或复制，一个在另一个之上。此外，双倍下降也不起作用。

以下是一个示例（底部组合框显示问题）：

这里是代码 - 我担心它会调用3个子程序，这些子程序都很冗长：

Private Sub SegmentComboBox_Change()

Call DrawTabCCView
PopTab
Call CCViewAddFormulasNew

End Sub

DrawTabCCView

Sub DrawTabCCView()


Dim C As Range
Dim D As Range
Dim D2 As Range

Dim CountryCol As Integer
Dim SegDetCol As Integer
Dim CompetitionCol As Integer
Dim BrandCol As Integer
Dim CompCol As Integer
Dim TotX As Range, Comp As Range

Dim PrevLabel As String

Application.ScreenUpdating = False

ThisWorkbook.Sheets("Country_Category view").Activate

'clear old data
Set D = ActiveSheet.Range("C13")

If D.Value <> "Total Category" Then Stop

Do Until D.Value = "" And D.End(xlDown) = ""

    Select Case D.Value

    Case "Total Category", "Total", "Private Labels", "Competition"
        PrevLabel = D.Value
        D.EntireRow.ClearContents
        D.Value = PrevLabel

        If D.Value = "Total Category" Then
            Set TotCat = D
        ElseIf D.Value = "Total" Then
            Set TotX = D
        ElseIf D.Value = "Private Labels" Then
            Set PL = D
        ElseIf D.Value = "Competition" Then
            Set Comp = D
        End If




    Case ""

        'do nothing

    Case Else

        If D.Offset(-2, 0) <> "" Then
            D.EntireRow.ClearContents
        Else
            Set D = D.Offset(-1, 0)
            D(2, 1).EntireRow.Delete
        End If

    End Select



    Set D = D.Offset(1, 0)
Loop

Set C = ThisWorkbook.Sheets("Raw Data (2)").Cells(1, 1)

Do Until C.Value = ""

    If C.Value = "Country" Then CountryCol = C.Column
    If C.Value = "Segment + Detail" Then SegDetCol = C.Column
    If C.Value = "Competition" Then CompetitionCol = C.Column
    If C.Value = "Local_Brand_Name" Then BrandCol = C.Column
    If C.Value = "Competition" Then CompCol = C.Column

    Set C = C.Offset(0, 1)
Loop

If CountryCol = 0 Then Stop
If SegDetCol = 0 Then Stop
If CompetitionCol = 0 Then Stop

Set C = C.Parent.Cells(2, 1)
Do Until C.Value = ""
    If C(1, CountryCol).Value = ActiveSheet.CountryComboBox.Value And C(1, SegDetCol).Value = ActiveSheet.SegmentComboBox.Value Then

        Select Case C(1, BrandCol)

        Case "Total Category", "Private Labels", "Total", "Dummy"
            'do nothing
        Case Else

            If C(1, CompCol) = "XXX" Then
                Set D = TotX.Offset(2, 0)
            ElseIf C(1, CompCol) = "Competition" Then
                Set D = Comp.Offset(2, 0)
            Else
                Stop
            End If

            Do Until D.Value = ""
                Set D = D.Offset(1, 0)
            Loop

            If D.Offset(-1, 0).Value <> "" Then
                D.EntireRow.Insert
                Set D = D.Offset(-1, 0)
            End If

            D.Value = C(1, BrandCol).Value

        End Select


    End If
    Set C = C.Offset(1, 0)
Loop



Application.ScreenUpdating = True


End Sub

PopTab

Sub PopTab()

Call PopulateTables(ThisWorkbook.ActiveSheet)
ActiveSheet.Range("A1").Activate

End Sub

CCViewAddFormulasNew

Sub CCViewAddFormulasNew()

Dim D As Range
Dim D2 As Range
Dim TabFilter(1 To 2, 4) As Variant


TabFilter(1, 0) = "Measure"
TabFilter(1, 1) = "Country"
TabFilter(1, 2) = "Segment + Detail"
TabFilter(1, 3) = "Period"
TabFilter(1, 4) = "Local_Brand_Name"

TabFilter(2, 0) = "XXX"
TabFilter(2, 1) = ActiveSheet.CountryComboBox.Value
TabFilter(2, 2) = ActiveSheet.SegmentComboBox.Value
TabFilter(2, 3) = "XXX"
TabFilter(2, 4) = "XXX"


Application.ScreenUpdating = False
If DontUpdate = False Then
    'Stop

    Set D = ThisWorkbook.Sheets("Country_Category view").Range("C13")

    Do Until D.Value = "" And D.End(xlDown).Value = ""
        If D.Value <> "" Then
            Set D2 = D(1, 3)

            'brand
            TabFilter(2, 4) = D.Value


            Do Until D2.Parent.Cells(11, D2.Column) = "" And D2.Parent.Cells(11, D2.Column + 1) = ""

                    TabFilter(1, 0) = D2.Parent.Cells(10, D2.Column).Value

                    TabFilter(2, 3) = D2.Parent.Cells(11, D2.Column).Value
                    D2.Value = FindValPivot(ThisWorkbook.Sheets("Raw Data"), TabFilter())

                    TabFilter(2, 3) = D2.Parent.Cells(11, D2.Column + 1).Value
                    D2(1, 2).Value = FindValPivot(ThisWorkbook.Sheets("Raw Data"), TabFilter())

                    If D2.Value <> "" And D2(1, 2).Value <> "" Then
                        D2(1, 3).FormulaR1C1 = "=RC[-1]/RC[-2] * 100"
                    End If

                    If IsError(D2(1, 3).Value) Then D2(1, 3).Value = "n/a"

                Set D2 = D2.Offset(0, 4)
            Loop
        End If

        Set D = D.Offset(1, 0)
    Loop

End If

Application.ScreenUpdating = True

ActiveSheet.Range("A1").Activate

End Sub

知道如何阻止这种情况发生吗？

干杯！

Answer 1

为了完整起见，这里的解决方案对我有用。我改编了enderland的代码。

如@Oliver Humphreys的评论所述，这似乎与不同的屏幕分辨率有关。我使用以下cmd命令在不同版本的Excel上测试了许多不同的机器，以验证测试机器的屏幕尺寸。

wmic desktopmonitor get screenheight, screenwidth

具有相同尺寸的机器显示ActiveX双图像没有问题。不管Excel版本或32/64位，都有不同尺寸的那些。

我已经调整了源代码以循环每个工作表并将每个ActiveX对象的设置写出到文本文件中，每个对象的详细信息之间都有一个空格。

我将此代码放在我使用的开发机器上的标准模块中，然后从那里运行它。理论上，您可以在单个计算机上运行此操作，您可以在其中创建特定维度的ActiveX对象，然后使用这些维度。

然后我使用输出信息来设置Workbook_Open事件。在这种情况下，我为所有ActiveX控件设置属性。而且，没有更多的双重图像和对象按预期运行。用户版本只有Workbook_Open代码。

将Workbook_Open代码留在分布式工作簿中的原因是向前分发。

获取现有维度的代码：

Option Explicit

Private Sub printAllActiveXSizeInformation()

    Dim myWS As Worksheet
    Dim OLEobj As OLEObject
    Dim obName As String
    Dim shName As String
    Dim mFile As String
    mFile = "C:\Users\yourusername\Desktop\ActiveXInfo.txt"

    Open mFile For Output As #1


    For Each myWS In ThisWorkbook.Worksheets

        shName = myWS.Name

        With myWS

            For Each OLEobj In myWS.OLEObjects

                obName = OLEobj.Name

                Print #1, "'" + obName
                Print #1, shName + "." + obName + ".Left=" + CStr(OLEobj.Left)
                Print #1, shName + "." + obName + ".Width=" + CStr(OLEobj.Width)
                Print #1, shName + "." + obName + ".Height=" + CStr(OLEobj.Height)
                Print #1, shName + "." + obName + ".Top=" + CStr(OLEobj.Top)
                Print #1, "ActiveSheet.Shapes(""" + obName + """).ScaleHeight 1.25, msoFalse, msoScaleFromTopLeft"
                Print #1, "ActiveSheet.Shapes(""" + obName + """).ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft"
                Print #1, vbNewLine

            Next OLEobj

        End With

    Next myWS

    Close #1

    Shell "NotePad " + mFile

End Sub

示例Workbook_Open事件代码：

Private Sub Workbook_Open()

    Dim wb As Workbook
    Dim ws as Worksheet
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet1")  'add more as appropriate

    With ws

      .OLEObjects("ComboBox1").Left = 269
      .OLEObjects("ComboBox1").Width = 173
      .OLEObjects("ComboBox1").Height = 52.5
      .OLEObjects("ComboBox1").Top = 179.5
      .Shapes("ComboBox1").ScaleHeight 1.25, msoFalse, msoScaleFromTopLeft

    End With

End Sub

或者，切换到表单控件。

Excel Comboboxes在某些PC上加倍

1 个答案: