问题
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):
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
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
Any idea how to stop this happening?
Cheers!
回答1:
For the sake of completeness here is the solution that worked for me. I adapted the code from enderland.
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
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.
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.
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.
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.
The reason for leaving the Workbook_Open code in the distributed workbooks is in case of onward distribution.
Code to get existing dimensions:
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
Example Workbook_Open event code:
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.
来源：https://stackoverflow.com/questions/31875676/excel-comboboxes-double-up-on-some-pcs