Excel Comboboxes 在某些 PC 上加倍

Question

我有一个 Excel 工作簿，它使用 activeX 组合框来运行 VBA 代码。它在大多数 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

弹出标签

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 在 cmets 中所指出的，这似乎与不同的屏幕分辨率有关。我在多台不同的机器上进行了测试，使用不同版本的 Excel，使用以下 cmd 命令验证测试机器的屏幕尺寸。

wmic desktopmonitor get screenheight, screenwidth

相同尺寸的机器显示 ActiveX 双图像没有问题。无论 Excel 版本或 32/64 位如何，尺寸不同的人都会这样做。

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

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

然后我使用输出信息设置Workbook_Open 事件。在这种情况下，我设置了所有 ActiveX 控件的属性。瞧，不再有双重图像，对象按预期运行。用户版本中只有 Workbook_Open Code。

将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

---

或者，切换到表单控件。