Excel组合框在某些PC上会加倍 [英] Excel Comboboxes double up on some PCs

问题描述

我有一个Excel工作簿，女巫使用activeX组合框来运行VBA代码。在大多数PC上都可以正常工作。

I've got an excel workbook witch uses activeX comboboxes to run VBA code. It works fine on most PCs.

但是，我的一些客户发现，当他们单击组合框时，组合框似乎在翻倍或重复，一个在另一个之上。

However some of my clients find that when they click on the comboboxes the combobox appears to double up or duplicate, one on top of the other. Also the doubled up drop down doesn't function.

这里是一个示例（底部组合框显示了问题）：

Here's an example (bottom combobox displays the issue):

这里是代码-恐怕它调用了3个子程序，它们都很长：

Here's the code - I'm afraid it calls 3 subroutines which are all quite lengthy:

Private Sub SegmentComboBox_Change()

Call DrawTabCCView
PopTab
Call CCViewAddFormulasNew

End Sub

DrawTabCCView

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

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

任何想法如何阻止这种情况发生？

Any idea how to stop this happening?

干杯！

推荐答案

为了完整起见，这是对我有用的解决方案。
我改写了 enderland 。

For the sake of completeness here is the solution that worked for me. I adapted the code from enderland.

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

As noted in comments by @Oliver Humphreys, this seems to be related to differing screen resolutions. I tested on a number of different machines, with different versions of Excel, using the following cmd command to verify test machines screen dimensions.

wmic desktopmonitor get screenheight, screenwidth

具有相同尺寸的计算机对ActiveX double-没有问题，图片。不论Excel版本或32/64位版本，那些尺寸不同的文件都可以。

The machines with the same dimensions showed no problem with the ActiveX double-image. Those with differing dimensions did, irrespective of Excel version or 32/64 bit.

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

I have adapted the source code to loop each sheet and write out the settings of each ActiveX object, to a text file, with a space in between each object's details.

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

I put this code in a standard module, on the development machine I use, and ran it from there. You could in theory run this on individual machines, where you create an ActiveX object of particular dimensions, and then use those dimensions.

然后我使用输出信息进行设置 Workbook_Open 事件。在这种情况下，我将设置所有ActiveX控件的属性。而且，不再需要双重图像，该对象将按预期运行。用户版本仅包含Workbook_Open代码。

I then used the output information to set up Workbook_Open event. In this event I set the properties for all the ActiveX controls. And voilà, no more double image and the object functions as expected. Users versions had only the Workbook_Open Code in.

将 Workbook_Open 代码保留在分布式工作簿中的原因是

The reason for leaving the Workbook_Open code in the distributed workbooks is in case of onward distribution.

获取现有尺寸的代码：

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

---

或者，切换到表单控件。

---

Alternatively, switch to form controls.

这篇关于Excel组合框在某些PC上会加倍的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！