我有一个包含三张纸的Excel工作簿; 'ControPanel'，'Charts'和'Dump'，按顺序排列。所有用户交互都在“ControlPanel”上执行。 “图表”只包含预定义的图表，这些图表引用了根据“ControlPanel”和“转储”中的数据动态调整大小的命名范围。
'ControlPanel'提供了两个控制按钮，'Import'和'Clear'，用户可以使用它们来启动宏。还有一个进度条可以计量导入过程。无论何时按下任何一个按钮，宏都按设计执行，但无论出于何种原因，“图表”表都会获得焦点。这违背了进度条的目的。
任何人都可以解释是什么导致'图表'表格聚焦和/或如何防止它？
在每个宏的开头，我这样做......
xlStatusBarState = Application.DisplayStatusBar
Application.DisplayStatusBar = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
但是，在每个宏中，必须更新进度条，这需要重新打开ScreenUpdating。以下是更新进度条的例程（xFileCnt和xDoneCnt是全局的）..
Public Sub UpdateProgress()
Dim progress As Double
Dim screenUpdate As Boolean
Dim wsCp As Worksheet
Set wsCp = ThisWorkbook.Worksheets("ControlPanel")
'store previous setting
screenUpdate = Application.ScreenUpdating
Application.ScreenUpdating = True
'div by 0 protection
If xFileCnt > 0 Then
progress = (xDoneCnt / xFileCnt)
If progress > 0 Then
If progress > 1 Then
progress = 1
End If
Else
progress = 0
End If
Else
progress = 0
End If
wsCp.Range("rangeProgress").Value = progress
'update screen
wsCp.Calculate
DoEvents
'restore
Application.ScreenUpdating = screenUpdate
Set wsCp = Nothing
End Sub
没有宏直接绑定到“图表”表。
我最初添加了DoEvents行，因为进度条在没有的情况下无法可靠地更新。我已经尝试删除它，但它对“图表”表没有任何影响。我无法确定它是否再次破坏了进度条，因为“图表”表一直在窃取焦点。
我确信我可以提供更多信息，但我可能已经用讽刺的方式压倒了所有人。任何反馈都非常感谢。
***导入功能
Public Sub From_XML_To_XL()
'UpdatebyKutoolsforExcel20151214
'Modified from KuTools for Excel
Dim wbXmlTmp As Workbook
Dim wbThis As Workbook
Dim wsDump As Worksheet
Dim wsCp As Worksheet
Dim namedRange As Name
Dim xmlDpNameRange As Range
Dim xmlDpDataRange As Range
Dim trendDpNameRange As Range
Dim trendDpDataRange As Range
Dim xFileDialog As FileDialog
Dim xStrPath As String
Dim xFile As String
Dim xFileName As Variant
Dim allFiles As Variant
Dim tmpDebug As Variant
Dim xEntryCol As Long
Dim xDataCnt As Long
Dim dpCnt As Long
Dim xlStatusBarState As Boolean
Dim timeStamp As Variant
On Error GoTo ErrHandler
'clear variables
xDataCnt = 0
xDoneCnt = 0
xFileCnt = 0
xEntryCol = 0
dpCnt = 0
xlStatusBarState = Application.DisplayStatusBar
Application.DisplayStatusBar = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Application.EnableEvents = False
'init progress bar
Call UpdateProgress
'update status
Call UpdateStatus("")
'create and display file selection dialog
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then
Err.Raise Number:=vbObjectError + 513, _
Description:="Invalid File Path"
End If
'create file path
xFile = Dir(xStrPath & "\*.xml")
'update file count for progress bar
Do While xFile <> ""
xFileCnt = xFileCnt + 1
xFile = Dir()
Loop
If Not xFileCnt > 0 Then
Err.Raise Number:=vbObjectError + 513, _
Description:="No Files Found"
End If
'create file path
xFile = xStrPath & "\*.xml"
'load array
allFiles = GetFileList(xFile)
If IsArray(allFiles) = False Then
Err.Raise Number:=vbObjectError + 513, _
Description:="Not an array"
End If
'init progress bar
Call UpdateProgress
'update status
Call UpdateStatus("Sorting " & xFileCnt & " files")
'sort array
Call QuickSort(allFiles, LBound(allFiles), UBound(allFiles))
'reference this workbook
Set wbThis = ThisWorkbook
Set wsCp = wbThis.Worksheets("ControlPanel")
Set wsDump = wbThis.Worksheets("Dump")
'load file counter
xDataCnt = wsDump.Range("rangeCount").Value
'validate xDataCnt
If IsNumeric(xDataCnt) = False Then
xDataCnt = 0
End If
'init counter
If xDataCnt = 0 Then
'not data captured
'start at column 2
xEntryCol = 1
Else
'data exists, append new data
xEntryCol = xDataCnt + 2
End If
'define range of datapoints
Call defineDumpRange
'for all xml files in path, copy contents to this workbook
For Each xFileName In allFiles
'update status
'sheet protected by this routine
Call UpdateStatus("Copying " & xFileName)
'open xml in new workbook
Set wbXmlTmp = Workbooks.OpenXML(fileName:=xStrPath & "\" & xFileName, LoadOption:=xlXmlLoadImportToList)
'number rows in file
dpCnt = wbXmlTmp.Sheets(1).UsedRange.Rows.Count
'swap name and data columns
'tmpDebug = Cells(dpCnt, 2)
Set xmlDpNameRange = wbXmlTmp.Sheets(1).Range("B1", Cells(dpCnt, 2))
Set xmlDpDataRange = wbXmlTmp.Sheets(1).Range("A1", Cells(dpCnt, 1))
'copy datapoint name to this workbook
'only if this is first time populating worksheet
If xDataCnt = 0 Then
'first import
'copy datapoint name column
Set trendDpNameRange = wsDump.Cells(3, xEntryCol).Resize(xmlDpNameRange.Rows.Count, 1)
trendDpNameRange.Value = xmlDpNameRange.Value
'point to next column
xEntryCol = xEntryCol + 1
'resize datapoint name range
Set namedRange = wbThis.Names.Item("dpNamesRange")
With namedRange
.RefersTo = .RefersToRange.Resize(trendDpNameRange.Rows.Count, 1)
End With
Set namedRange = Nothing
End If
'increment file count
xDataCnt = xDataCnt + 1
'load count into field
wsDump.Cells(1, xEntryCol).Value = xDataCnt
'copy datapoint data to this workbook
Set trendDpDataRange = wsDump.Cells(3, xEntryCol).Resize(xmlDpDataRange.Rows.Count, 1)
trendDpDataRange.Value = xmlDpDataRange.Value
'parse time stamp and write to cell
timeStamp = getTimeStamp(xEntryCol)
wsDump.Cells(2, xEntryCol).Value = timeStamp
wsDump.Cells(2, xEntryCol).NumberFormat = "dd/mm/yyyy hh:mm:ss"
'point to next column
xEntryCol = xEntryCol + 1
'close xml workbook w/o saving
wbXmlTmp.Close False
'release memory
Set xmlDpNameRange = Nothing
Set xmlDpDataRange = Nothing
Set trendDpNameRange = Nothing
Set trendDpDataRange = Nothing
Set wbXmlTmp = Nothing
'increment progress
xDoneCnt = xDoneCnt + 1
'update accumualted total
wsDump.Range("rangeCount").Value = xDataCnt
'sheet protected by this routine
Call UpdateProgress
Next
'resize named ranges
Set namedRange = wbThis.Names.Item("dumpData")
With namedRange
.RefersTo = .RefersToRange.Resize(wsDump.UsedRange.Rows.Count, wsDump.UsedRange.Columns.Count)
End With
Set namedRange = wbThis.Names.Item("cpData")
With namedRange
.RefersTo = .RefersToRange.Resize(wsCp.Range("listRange").Rows.Count + 1, wsDump.UsedRange.Columns.Count - 1)
End With
Set namedRange = Nothing
'update cp data
Call updateCpSheet
'update status
UpdateStatus ("Complete")
'save file
wbThis.Save
'release memory
Set wsDump = Nothing
Set wsCp = Nothing
Set wbThis = Nothing
Application.DisplayStatusBar = xlStatusBarState
'Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
'exit
Exit Sub
ErrHandler:
MsgBox Err.Description, vbOKOnly, ""
Application.DisplayStatusBar = xlStatusBarState
'Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
*****更新状态子
Public Sub UpdateStatus(Txt As String)
Dim screenUpdate As Boolean
Dim wsCp As Worksheet
Set wsCp = ThisWorkbook.Worksheets("ControlPanel")
'store previous setting
screenUpdate = Application.ScreenUpdating
Application.ScreenUpdating = True
Call sheetProtection(False)
'update status
wsCp.Range("rangeStatus").Value = Txt
'update screen
wsCp.Calculate
DoEvents
Call sheetProtection(True)
'restore
Application.ScreenUpdating = screenUpdate
Set wsCp = Nothing
End Sub
**表保护子
Public Sub sheetProtection(protect As Boolean)
Dim ws As Worksheet
If protect = True Then
For Each ws In ActiveWorkbook.Worksheets
ws.EnableSelection = xlUnlockedCells
ws.protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
Next ws
Else
For Each ws In ActiveWorkbook.Worksheets
ws.Unprotect
Next ws
End If
End Sub
-