Web query refresh error - vba

I have 3 workbook web queries on a single data sheet , and I have a dropdown object with a list of months in the year (1-12). My idea for the automation was to have the query formula update based on the user selection of the dropdown value and update the query formula accordingly and refresh.
The VBA code works fine, but I get this message for one of the queries.
The reason is that the query (ex when changed from month 2 to month 3), has 2 more lines and is not the exact table height.
Any ideas how to debug this / circumvent this message. Code below:
Sub DropDown9_Change()
Dim wbconn As WorkbookConnection, qT As QueryTable
Dim wB As Workbook, wS As Worksheet
'For Each wbconn In ThisWorkbook.Connections
'Debug.Print wbconn.Name & " - " & wbconn.OLEDBConnection.CommandText & " - " & _
'wbconn.OLEDBConnection.SourceDataFile
''wbconn.Refresh
'Next wbconn
Set wB = Workbooks("OH Burdening Template.xlsb")
If ShData.Shapes("Drop Down 9").ControlFormat.Value > _
ShCalendar.Range("B3").Value Then
MsgBox "Cannot be based on future periods!", vbExclamation
Else
'Refresh WB queries
Call Refresh_Queries(ShData.Shapes("Drop Down 9").ControlFormat.Value, wB, ShData)
End If
ShData.Columns.AutoFit
End Sub
Private Function Refresh_Queries(ByVal Period As Integer, ByVal wB As Workbook, _
ByVal thisSheet As Worksheet)
With Application
.StatusBar = "Now refreshing queries on :" & ShData.Name
.ScreenUpdating = False
.EnableEvents = False
End With
Dim I As Integer, LObj As ListObject
Dim strL As Integer, str As String
Dim Pos As Integer
Dim F As String
Dim startPos As Integer
str = "?year=2018&period="
strL = Len(str)
For I = 1 To wB.Queries.Count
On Error GoTo view_err
F = wB.Queries(I).Formula
Pos = VBA.InStr(1, F, str, vbBinaryCompare)
startPos = Pos + strL
'Debug.Print F
'Replacing the period part of the string with the period entered in the dropdown
F = WorksheetFunction.Replace(F, startPos, 1, Period)
wB.Queries.Item(I).Formula = F
'Debug.Print Mid(F, startPos, 1)
Next I
For Each LObj In thisSheet.ListObjects
Application.StatusBar = "Refreshing " & LObj.Name
LObj.QueryTable.Refresh False
Debug.Print LObj.Name & Chr(32) & "Refreshed successfully!"
Next LObj
With Application
.StatusBar = False
.ScreenUpdating = True
.EnableEvents = True
End With
Set LObj = Nothing
Exit Function
view_err:
Debug.Print LObj.Name & Chr(32) & "Refresh Failed!"
MsgBox Err.Description & " (" & Err.Number & ")", vbExclamation
With Application
.StatusBar = False
.ScreenUpdating = True
.EnableEvents = True
End With
End Function

Related

VLookup from excel workbook on a network drive

Right now I have 8 different textbox controls on a UserForm that when a value is entered a macro runs to open a workbook saved on a network folder then a VLookup is run. Below is the code for two of the TextBox controls and as you can see (due to my lack of coding ability); I ended up with 8 separate subs for each of the text boxes which opens up the workbook on the shared drive after a value is entered in the text box then closes the workbook and is not very efficient. After some research I am thinking of using Index and Match would be a better solution, but have no familiarity with those excel functions in VBA and could use some help with getting a starting point using Index and Match, if that is a better solution. Thank you all for your assistance.
Sub b1CIF()
Dim CustList As Workbook
Dim thisWB As Workbook
Dim thisWS As Worksheet
Dim wsRR As Worksheet
Dim bColor As Range
Dim Msg, Style, Title, Response
Msg = "OOOPS!" & vbNewLine & vbNewLine & "The CIF Number of " & LendStart.lsPBCIF.Value & " " & "is not correct or does not exist." & vbNewLine & "Please re-enter the CIF Number."
Style = vbOKCancel + vbCritical
Title = UCase("***CIF Data Entry Error!***")
Application.ScreenUpdating = False
Set CustList = Workbooks.Open("L:\Deposits\Information\Customers.xlsm")
Set thisWB = ThisWorkbook
Set thisWS = thisWB.Sheets("SavedInfo")
Set wsRR = thisWB.Sheets("RiskRating")
Set bColor = wsRR.Range("C3")
On Error GoTo ErrHandler
' NAME GRAB
If thisWS.Range("A2") <> "" Then
thisWS.Range("PBName").Value = _
WorksheetFunction.VLookup(thisWS.Range("A2").Value, CustList.Sheets("CIFMAST").Range("A1:Z50000"), 2, False)
With LendStart.lsPBName
.Value = thisWS.Range("PBName")
.Visible = True
.Locked = True
.BackColor = bColor.Interior.Color
.Font.Bold = True
.Font.Size = 9
.TextAlign = fmTextAlignCenter
.TabStop = False
End With
thisWB.Sheets("BorrInfo").Range("PB").Value = thisWS.Range("PBName")
' TELEPHONE NUMBER GRAB
thisWB.Sheets("BorrInfo").Range("PBPhone").Value = _
WorksheetFunction.VLookup(thisWS.Range("A2").Value, CustList.Sheets("CIFMAST").Range("A1:Z50000"), 9, False)
End If
CustList.Close
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
LendStart.lsPBSCIF.Value = ""
With LendStart.lsPBName
.Value = ""
.Locked = True
End With
Response = MsgBox(Msg, Style, Title)
CustList.Close
Application.ScreenUpdating = True
End Sub
Sub b2CIF()
Dim CustList As Workbook
Dim thisWB As Workbook
Dim thisWS As Worksheet
Dim wsRR As Worksheet
Dim bColor As Range
Dim Msg, Style, Title, Response
Msg = "The CIF Number entered " & LendStart.lsPBSCIF.Value & " " & "is not correct." & vbNewLine & "Please re-enter the CIF Number."
Style = vbOKCancel + vbCritical
Title = UCase("***CIF data entry error!***")
Application.ScreenUpdating = False
Set CustList = Workbooks.Open("L:\Deposits\Information\Customers.xlsm")
Set thisWB = ThisWorkbook
Set thisWS = thisWB.Sheets("SavedInfo")
Set wsRR = thisWB.Sheets("RiskRating")
Set bColor = wsRR.Range("C3")
On Error GoTo ErrHandler
' NAME GRAB
If thisWS.Range("A3") <> "" Then
thisWS.Range("PBSName").Value = _
WorksheetFunction.VLookup(thisWS.Range("A3").Value, CustList.Sheets("CIFMAST").Range("A1:Z50000"), 2, False)
With LendStart.lsPBSName
.Value = thisWS.Range("PBSName")
.Visible = True
.Locked = True
.BackColor = bColor.Interior.Color
.Font.Bold = True
.Font.Size = 9
.TextAlign = fmTextAlignCenter
.TabStop = False
End With
thisWB.Sheets("BorrInfo").Range("PBS").Value = thisWS.Range("PBSName")
' TELEPHONE NUMBER GRAB
thisWB.Sheets("BorrInfo").Range("PBSPhone").Value = _
WorksheetFunction.VLookup(thisWS.Range("A3").Value, CustList.Sheets("CIFMAST").Range("A1:Z50000"), 9, False)
End If
CustList.Close
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
LendStart.lsPBSCIF.Value = ""
Response = MsgBox(Msg, Style, Title)
CustList.Close
Application.ScreenUpdating = True
End Sub

Workbook becomes corrupted and won't open after macro saves with certain number of sheets

In one excel instance (Instance A), my workbook (Workbook A) performs calculations based on user inputs and creates a worksheet with a chart object. This worksheet is copied and pasted into another workbook (Workbook B), which is closed in Instance A and then opened in a second excel instance (Instance B). Workbook B/Instance B are kept open and in a separate window, as the function of Workbook A/Instance A is to create worksheets to be viewed in Workbook B/Instance B.
So the macro process is: Worksheet is created in Instance A/Workbook A -> Workbook B is closed in Instance B -> Workbook B is opened in Instance A -> worksheet is copied from Workbook A to Workbook B -> Workbook B is saved/closed in Instance A -> Workbook B is opened in Instance B
In the interest of full disclosure, this is the entire sub:
Sub CopySSToNewWorkbook()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim MoveFromWkb As Workbook
Dim MoveFromSht As Worksheet
Dim ChartName As String
Dim RngToCover As Range
Dim duplicateChtPic As Shape
Dim NewSheetName As String
Dim TagString As String
If InputPage.Range("PanelTag") <> "" Then TagString = "-" & InputPage.Range("PanelTag").Text
Set MoveFromWkb = ThisWorkbook
'Set MoveFromSht = MoveFromWkb.Sheets("InputPage")
If InputPage.Range("PgNum") <> "" Then
NewSheetName = InputPage.Range("RoomNum").Text & TagString & " (Pg" & InputPage.Range("PgNum") & ")"
Set MoveFromSht = MoveFromWkb.Worksheets(NewSheetName)
Else
NewSheetName = InputPage.Range("RoomNum").Text & TagString
Set MoveFromSht = MoveFromWkb.Worksheets(NewSheetName)
End If
Set RngToCover = MoveFromSht.Range("E19:Y34")
ChartName = "Panel" & InputPage.Range("PgNum")
'Duplicate method
Set duplicateChtPic = MoveFromSht.ChartObjects(ChartName).Duplicate()
MoveFromSht.Shapes(ChartName).Delete
duplicateChtPic.ZOrder msoSendToBack
duplicateChtPic.Select
Call DelinkChartFromData
With duplicateChtPic
.height = RngToCover.height ' resize
.Width = RngToCover.Width ' resize
.top = RngToCover.top - 2 ' reposition
.Left = RngToCover.Left - 6 ' reposition
End With
MoveFromSht.Shapes("SaveSpoolSheetButton").Delete
MoveFromSht.Shapes("EditSpoolSheetButton").Visible = msoTrue
MoveFromSht.Shapes("UpdatePageNumberButton").Visible = msoTrue
MoveFromSht.Shapes("DeletePanelButton").Visible = msoTrue
Dim CNumber As String
Dim RelNum As String
Dim CrtNum As String
Dim Percentage As String
Dim SSFolderName As String
Dim Wkbname As String
Dim FileLocation As String
Dim Sht As Worksheet
Dim SSCopyYesNo As Integer
Dim DoubleSheet As Boolean
Dim MoveToWkb As Workbook
Dim MoveToSht As Worksheet
Dim PasteSheet As Worksheet
Dim CellName As name
Dim SheetCounter As Integer
SheetCounter = 1
Dim i As Integer
Dim varLinks As Variant
With InputPage
CNumber = .Range("JNumber").Text
CrtNum = "Crt" & .Range("CrateNum").Text
RelNum = "Rel" & .Range("RelNum").Text
Percentage = (.Range("RelPct").value * 100) & "Pct"
End With
If CNumber <> "" Then
Wkbname = Wkbname & CNumber
End If
If RelNum <> "Rel" Then
Wkbname = Wkbname & "_" & RelNum
End If
If CrtNum <> "Crt" Then
Wkbname = Wkbname & "_" & CrtNum
End If
If Percentage <> "0Pct" Then
Wkbname = Wkbname & "_" & Percentage
End If
SSFolderName = CreateSSFolders
FileLocation = SSFolderName & "\" & Wkbname & ".xlsb"
Dim newXL As Excel.Application
'Set newXL = GetObject(FileLocation).Application
If IsFileOpen(FileLocation) = True Then
Set newXL = GetObject(FileLocation).Application
newXL.Application.ScreenUpdating = False
newXL.DisplayAlerts = False
newXL.Application.Workbooks(Wkbname & ".xlsb").Close SaveChanges:=False
' newXL.Application.Quit
' Set newXL = Nothing
Else
Set newXL = CreateObject("Excel.Application")
newXL.Visible = True
End If
If FileFolderExists(FileLocation) Then
' newXL.Application.ScreenUpdating = False
' newXL.Application.DisplayAlerts = False
' On Error Resume Next
' newXL.Workbooks(Wkbname & ".xlsb").Close SaveChanges:=False
' On Error GoTo 0
Workbooks.Open FileLocation, UpdateLinks:=False, ReadOnly:=False
Set MoveToWkb = Workbooks(Wkbname & ".xlsb")
Else
Workbooks.Open (InputPage.MainFolderLocation.Text & "calc_and_trans\SpoolSheetWorkbookTemplate.xlsb")
Set MoveToWkb = Workbooks("SpoolSheetWorkbookTemplate.xlsb")
'if SSFolder doesn't already exist, the EditSpoolSheet module is imported to the new spoolsheet
'it is also exported to update any changes made
If FileFolderExists(InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas") Then 'change path for home
MoveFromWkb.VBProject.VBComponents("EditSpoolSheet").export InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas" 'change path for home
MoveToWkb.VBProject.VBComponents.Import InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas" 'change path for home
Else
MoveFromSht.Shapes("EditSpoolSheetButton").Visible = msoFalse
MoveFromSht.Shapes("UpdatePageNumberButton").Visible = msoFalse
MoveFromSht.Shapes("CancelEditButton").Visible = msoFalse
MoveFromSht.Shapes("DeletePanelButton").Visible = msoFalse
End If
End If
For Each CellName In MoveToWkb.Names
If Right(CellName.name, 10) <> "Print_Area" Then
CellName.Delete
End If
Next
Dim NewPgNum As String
Dim OldPgNum As String
Dim startRead As Integer
Dim continueRun As Boolean
continueRun = False
NewPgNum = InputPage.Range("PgNum")
For Each Sht In MoveToWkb.Worksheets
startRead = InStr(Sht.name, "(Pg")
If Mid(Sht.name, startRead + 3) = (Right(MoveFromSht.name, Len(NewPgNum) + 1)) And DoubleSheet = False Then
DoubleSheet = True
Application.ScreenUpdating = True
SSCopyYesNo = MsgBox("Do you want to overwrite " & Sht.name & "?", vbYesNo + vbQuestion)
Application.ScreenUpdating = False
If SSCopyYesNo = vbYes Then
Dim spoolPosition As Integer
spoolPosition = Sht.Index
Sht.name = "_"
'attaching a macro to the edit spool sheet button
If FileFolderExists(InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas") Then 'change path for home
MoveFromSht.Shapes("EditSpoolSheetButton").OnAction = "EditSpoolSheetClicked"
MoveFromSht.Shapes("UpdatePageNumberButton").OnAction = "UpdatePageNumberClicked"
MoveFromSht.Shapes("CancelEditButton").OnAction = "CancelEditButtonClicked"
MoveFromSht.Shapes("DeletePanelButton").OnAction = "DeletePanelButtonClicked"
End If
MoveFromSht.Range("Page_Number") = MoveFromSht.Range("AK21")
MoveFromSht.Copy After:=MoveToWkb.Sheets(spoolPosition)
Application.DisplayAlerts = False
Sht.Delete
Application.CutCopyMode = False
continueRun = True
End If
ElseIf DoubleSheet <> True Then
DoubleSheet = False
End If
SheetCounter = SheetCounter + 1
Next
If DoubleSheet = False Then
Set PasteSheet = Workbooks(MoveToWkb.name).Worksheets.Add
' MoveFromSht.Copy before:=MoveToWkb.Sheets(1)
'attaching a macro to the edit spool sheet button
If FileFolderExists(InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas") Then 'change path for home
MoveFromSht.Shapes("EditSpoolSheetButton").OnAction = "EditSpoolSheetClicked"
MoveFromSht.Shapes("UpdatePageNumberButton").OnAction = "UpdatePageNumberClicked"
MoveFromSht.Shapes("CancelEditButton").OnAction = "CancelEditButtonClicked"
MoveFromSht.Shapes("DeletePanelButton").OnAction = "DeletePanelButtonClicked"
End If
MoveFromSht.Range("Page_Number") = MoveFromSht.Range("AK21")
MoveFromSht.Copy After:=MoveToWkb.Sheets(SheetCounter)
Application.CutCopyMode = False
continueRun = True
End If
If continueRun Then
For Each Sht In MoveToWkb.Worksheets
If Mid(Sht.name, 1, 5) = "Sheet" Then
Application.DisplayAlerts = False
Sht.Delete
End If
Next
Set MoveToSht = MoveToWkb.Sheets(MoveFromSht.name)
Dim moveToShtName As String
moveToShtName = MoveToSht.name
'fix in here
For Each CellName In MoveToWkb.Names
If Right(CellName.name, 10) <> "Print_Area" Then
Application.DisplayAlerts = False
CellName.Delete
End If
Next
Application.PrintCommunication = False
MoveToSht.DisplayPageBreaks = False
'For Each Sht In MoveToWkb.Worksheets
With MoveToSht.PageSetup
.PrintArea = "$A$1:$Z$36"
.Orientation = xlLandscape
.PaperSize = xlPaperLetter
.BlackAndWhite = True
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.LeftMargin = Application.InchesToPoints(1.6)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.CenterHorizontally = True
.CenterVertically = True
End With
Application.PrintCommunication = True
'%%%%%%%%new crate code %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'******************* Update Crate Sheet Info **************************************'
Dim crateSht As Worksheet
Dim frontSht As Worksheet
Set crateSht = MoveToWkb.Sheets("Crate_List")
Set frontSht = MoveToWkb.Sheets("FrontSheet")
Dim writeRow As Integer
Dim continueToEnd As Boolean
Dim roomColumn As Integer, pageColumn As Integer, sizeColumn As Integer, widthColumn As Integer, typeColumn As Integer, tagColumn As Integer
Dim infoTableCol As Integer
Dim colStep As Integer
For colStep = 1 To 15
Select Case crateSht.Cells(1, colStep).Text
Case "ROOM #"
roomColumn = colStep
Case "PAGE #"
pageColumn = colStep
Case "PANEL SIZE"
sizeColumn = colStep
Case "PANEL WIDTH"
widthColumn = colStep
Case "SQFT"
infoTableCol = colStep
Case "PANEL TYPE"
typeColumn = colStep
Case "PANEL TAG"
tagColumn = colStep
End Select
Next
'if first spoolsheet being added, set constant values (job name, job number etc.)
If MoveToWkb.Sheets.count = 3 Then
frontSht.Cells(5, 6) = MoveToSht.Range("AK2")
frontSht.Cells(6, 6) = MoveToSht.Range("AK3")
Dim EventsState As Boolean
EventsState = Application.EnableEvents
Application.EnableEvents = False
frontSht.Cells(6, 12) = MoveToSht.Range("AK7")
Application.EnableEvents = EventsState
End If
'determines where to write panel data: if row is blank, if Page # being written and read are both "" and panel tag/room # match, and if page numbers are not "" and match
For writeRow = 2 To 500
If Len(crateSht.Range("A" & writeRow).value) = 0 Or (InputPage.Range("PgNum") = "" And crateSht.Cells(writeRow, pageColumn).value = "" And crateSht.Range("A" & writeRow).value = InputPage.Range("RoomNum").value And _
crateSht.Cells(writeRow, tagColumn).value = InputPage.Range("PanelTag").value) Or (InputPage.Range("PgNum").value <> "" And _
InputPage.Range("PgNum").value = crateSht.Cells(writeRow, pageColumn).value) Then
'If continueToEnd Then
Exit For
End If
Next
Dim panelCrateData(24) As Variant
Dim panelTableData As Variant
panelTableData = MoveToSht.Range("AK1:AK39")
'writing spoolsheet information to crate sheet
With MoveToSht
If roomColumn <> 0 Then crateSht.Cells(writeRow, roomColumn) = panelTableData(22, 1) '.Range("AK22")
If pageColumn <> 0 Then crateSht.Cells(writeRow, pageColumn) = panelTableData(21, 1) '.Range("AK21")
If sizeColumn <> 0 Then crateSht.Cells(writeRow, sizeColumn) = panelTableData(13, 1) '.Range("AK13")
If widthColumn <> 0 Then crateSht.Cells(writeRow, widthColumn) = panelTableData(12, 1) ' .Range("AK12")
If tagColumn <> 0 Then crateSht.Cells(writeRow, tagColumn) = panelTableData(24, 1)
If typeColumn <> 0 Then crateSht.Cells(writeRow, typeColumn) = panelTableData(23, 1)
panelCrateData(0) = Round(CDbl(Replace(.Range("X35").Text, "SQFT", "")), 2)
panelCrateData(1) = panelTableData(15, 1) '.Range("AK15")
panelCrateData(2) = panelTableData(14, 1) '.Range("AK14")
panelCrateData(3) = panelTableData(17, 1) '.Range("AK17")
panelCrateData(4) = panelTableData(16, 1) '.Range("AK16")
panelCrateData(5) = panelTableData(18, 1) '.Range("AK18")
panelCrateData(6) = panelTableData(20, 1) '.Range("AK20")
panelCrateData(7) = panelTableData(19, 1) '.Range("AK19")
panelCrateData(8) = panelTableData(25, 1) '.Range("AK23")
panelCrateData(9) = panelTableData(26, 1) '.Range("AK24")
panelCrateData(10) = panelTableData(27, 1) '.Range("AK25")
panelCrateData(11) = panelTableData(29, 1) '.Range("AK27")
panelCrateData(12) = panelTableData(30, 1) '.Range("AK28")
panelCrateData(13) = panelTableData(31, 1) '.Range("AK29")
panelCrateData(14) = panelTableData(28, 1) '.Range("AK26")
panelCrateData(15) = panelTableData(34, 1) '.Range("AK32")
panelCrateData(16) = panelTableData(33, 1) '.Range("AK31")
panelCrateData(17) = panelTableData(35, 1) '.Range("AK33")
panelCrateData(18) = panelTableData(36, 1) '.Range("AK34")
panelCrateData(19) = panelTableData(37, 1) '.Range("AK35")
panelCrateData(20) = panelTableData(38, 1) '.Range("AK36")
panelCrateData(21) = panelTableData(39, 1) '.Range("AK37")
panelCrateData(22) = .Range("AU19")
'Holdback Info
panelCrateData(23) = .Range("AU12")
panelCrateData(24) = .Range("AU14")
'Additional Saddles
crateSht.Range(crateSht.Cells(writeRow, infoTableCol), crateSht.Cells(writeRow, infoTableCol + 24)) = panelCrateData ' "M" & writeRow & ":AK" & writeRow) = panelCrateData
End With
For writeRow = 2 To 500
If Len(crateSht.Range("A" & writeRow).value) = 0 Then ' Or crateSht.Range("A" & writeRow).value = InputPage.Range("RoomNum").value Then
'If continueToEnd Then
Exit For
End If
Next
Dim lastRow As Integer
lastRow = writeRow - 1
Dim totSqft As Double
totSqft = WorksheetFunction.Sum(crateSht.Range(crateSht.Cells(2, infoTableCol), crateSht.Cells(lastRow, infoTableCol))) '(crateSht 2:M" & lastRow))
Application.PrintCommunication = False
With crateSht
.PageSetup.PrintArea = "$A$1:$H$" & CStr(lastRow)
.PageSetup.PrintTitleRows = "$1:$1"
If lastRow = 2 Then .PageSetup.CenterHeader = "#" & MoveToSht.Range("AK3").value
.PageSetup.RightFooter = CStr(lastRow - 1) & " PANELS" & vbLf & "TOUCH UP KIT" & vbLf & "INTERCONNECTORS" _
& vbLf & "GLOVES" & vbLf & "T-BAR CLIPS" & vbLf & "INSULATION ON PANEL"
.PageSetup.RightHeader = CStr(totSqft) & " SQFT"
End With
Application.PrintCommunication = True
With frontSht
.Cells(11, 2) = lastRow - 1
.Cells(30, 2) = totSqft
End With
MoveToWkb.SaveAs filename:=FileLocation, FileFormat:=50
MoveToWkb.Close False
Set MoveToWkb = Nothing
'**********************************************************************************'
'Add new entry to recent panels table, unless room number already exists then replace that entry with the current info=
Call AddRecentPanelData
MoveFromSht.Delete
newXL.Application.ScreenUpdating = True
newXL.Application.DisplayAlerts = True
newXL.Application.AskToUpdateLinks = True
Application.Calculation = xlCalculationAutomatic
Set MoveFromWkb = Nothing
Set MoveFromSht = Nothing
Set MoveToSht = Nothing
newXL.Workbooks.Open FileLocation ', UpdateLinks:=False ', ReadOnly:=False
Set newXL = Nothing
Else
MoveToWkb.Close SaveChanges:=False
Set MoveToWkb = Nothing
newXL.Workbooks.Open FileLocation, UpdateLinks:=False, ReadOnly:=False
MoveFromSht.Delete
Application.Calculation = xlCalculationAutomatic
Set newXL = Nothing
Set MoveFromWkb = Nothing
Set MoveFromSht = Nothing
Set MoveToSht = Nothing
End If
Exit Sub
'#########################################################################################
ErrorHandler:
Dim Msg As String
If Err.number <> 0 Or Err.number <> 20 Then
Msg = "Error # " & Str(Err.number) & " was generated by " _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Call ReactiveUpdating
End Sub
So Workbook A uses this sub to create Workbook B/Instance B and save worksheets to it. The problem is, when Workbook A tries to add the 20th worksheet (sometimes 24th or 23rd but consistently in this area) there is an error in opening Workbook B in Instance B on this line (a couple scrolls up from the bottom) causing the code to break:
newXL.Workbooks.Open FileLocation, UpdateLinks:=False, ReadOnly:=False
Method 'Open' of object 'Workbooks' failed
If I click continue after this error pops up, it completes without an issue, but Workbook B in Instance B is corrupt. Also, if I click the X to close it Excel crashes, and Workbook B is corrupt/unable to open.
The strange thing is, it will always crash after the same number of worksheets are saved (between 20-23 worksheets). Even when I tried closing both workbooks and instances down completely after saving 19 times (just before the expected crash), saving the 20th worksheet still caused a crash.
This only started happening about a month ago, and it occurs on all the computers we have tested it on. We have even tested year old versions of the workbook, that certainly never had this issue, and they all have the same issue.
Please let me know if you can offer any help or need any more detail, any insight is greatly appreciated!
After a lot of work trying to change around the saving/opening process of the workbooks, I managed to figure out the issue. The workbook being saved (Workbook B) contained an ActiveX List Box control object, and after getting rid of it the issue went away. Hopefully this saves somebody the hours it took me to solve it!

Excel automatically add comment with cell edit history

I have the following code in the "sheet macros" (right click sheet - view code). It used to work but now it's not adding comments in my specified range A5:AQ155.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
'If (Target.Row > 3 And Target.Row < 155) Then Cells(Target.Row, "AT") = Now()
Const sRng As String = "A5:AQ155" ' change as required
Dim sOld As String
Dim sNew As String
Dim sCmt As String
Dim iLen As Long
Dim bHasComment As Boolean
With Target(1)
If Intersect(.Cells, Range(sRng)) Is Nothing Then Exit Sub
sNew = .Text
sOld = .Text
.Value = sNew
Application.EnableEvents = True
sCmt = "Edit: " & Format$(Now, "dd Mmm YYYY hh:nn:ss") & " by " & Application.UserName & Chr(10) & "Previous Text :- " & sOld
If Target(1).Comment Is Nothing Then
.AddComment
Else
iLen = Len(.Comment.Shape.TextFrame.Characters.Text)
End If
With .Comment.Shape.TextFrame
.AutoSize = True
.Characters(Start:=iLen + 1).Insert IIf(iLen, vbLf, "") & sCmt
End With
End With
End Sub
What have I done wrong?
The code stopped firing because Event Firing was disabled and never turned back on. The way the code is written, as soon as someone makes a change to the worksheet outside the range A5:AQ155, the Events become disabled without being turned back on, which means subsequent event triggers will not be fired (ie. - the next time you edit a cell).
If you make these slight tweaks in the code it should work as intended going forward.
However, before you do this type Application.EnableEvents = True in the immediate window and hit Enter to turn events back on so that the code begins to fire again.
Private Sub Worksheet_Change(ByVal Target As Range)
Const sRng As String = "A5:AQ155" ' change as required
Dim sOld As String
Dim sNew As String
Dim sCmt As String
Dim iLen As Long
If Not Intersect(Target, Me.Range(sRng)) Is Nothing Then
Application.EnableEvents = False
With Target
sNew = .Value2
Application.Undo
sOld = .Value2
.Value2 = sNew
Application.EnableEvents = True
sCmt = "Edit: " & Format$(Now, "dd Mmm YYYY hh:nn:ss") & " by " & Application.UserName & Chr(10) & "Previous Text :- " & sOld
If .Comment Is Nothing Then
.AddComment
Else
iLen = Len(.Comment.Shape.TextFrame.Characters.Text)
End If
With .Comment.Shape.TextFrame
.AutoSize = True
.Characters(Start:=iLen + 1).Insert IIf(iLen, vbLf, "") & sCmt
End With
End With
End If
End Sub
Here is the final code that got me the desired behavior. I changed the first IF statement according to #Scott Holtzman's comment. The IF statement now resets Application.EnableEvents = True before ending the macro with End Sub
EDIT: Included "Me." in "Me.range(sRng)"
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
'If (Target.Row > 3 And Target.Row < 155) Then Cells(Target.Row, "AT") = Now()
Const sRng As String = "A5:AQ155" ' change as required
Dim sOld As String
Dim sNew As String
Dim sCmt As String
Dim iLen As Long
Dim bHasComment As Boolean
With Target(1)
If Intersect(.Cells, Me.Range(sRng)) Is Nothing Then
Application.EnableEvents = True
Exit Sub
End If
sNew = .Text
sOld = .Text
.Value = sNew
Application.EnableEvents = True
sCmt = "Edit: " & Format$(Now, "dd Mmm YYYY hh:nn:ss") & " by " & Application.UserName & Chr(10) & "Previous Text :- " & sOld
If Target(1).Comment Is Nothing Then
.AddComment
Else
iLen = Len(.Comment.Shape.TextFrame.Characters.Text)
End If
With .Comment.Shape.TextFrame
.AutoSize = True
.Characters(Start:=iLen + 1).Insert IIf(iLen, vbLf, "") & sCmt
End With
End With
End Sub
Sub Hide_Comments_in_Workbook_Completely()
'This macro hides the comments and comment indicators - users wont know there is a comment within the excel workbook
Application.DisplayCommentIndicator = xlNoIndicator
End Sub

Display the difference between two cells in excel status bar

I was looking for code to determine the difference between two selected cells and display it in the status bar of Excel 2010.
I found some code, but it applies only to the workbook that contains that code.
Is it possible to make this code functional on every workbook I am working with?
It would be great if this kind of code runs automatically like macros from personal.xlsb.
Public Sub workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
Set sh = ActiveSheet
If Selection.Cells.Count = 2 Then
On Error Resume Next
If WorksheetFunction.Count(Range(Selection.Address)) = 2 Then
Application.StatusBar = "The difference is " & _
WorksheetFunction.Max(Range(Selection.Address)) _
- WorksheetFunction.Min(Range(Selection.Address))
Else
Application.StatusBar = "The difference is " & _
WorksheetFunction.Max(Range(Selection.Address))
End If
Else
Application.StatusBar = False
End If
End Sub
I found some code, but it applies only to the workbook that contains that code. Is it possible to make this code functional on every workbook I am working with?
You will have to create an Add-In for this. And then place this in your Add-In's ThisWorkbook module. After the Add-In has been created, activate it by checking its check-box on the Developer Tab, Add-Ins Section.
Private WithEvents oXLApp As Excel.Application
Private Sub Workbook_Open()
Set oXLApp = Excel.Application
End Sub
Private Sub oXLApp_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Range)
'
'~~> Rest of the code here
'
End Sub
These question resulted in the following tool.
Save the following project as .xla
Thisworkbook:
Private WithEvents oXLApp As Excel.Application
Private Sub Workbook_Open()
Set oXLApp = Excel.Application
End Sub
Private Sub oXLApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As range)
Dim limit As Long
limit = 300000 ' selection limit
Dim frmt As String
frmt = "#,##0;(#,##0);""-""" ' formating at status bar
' first condition - one selection area
If Selection.Areas.Count = 1 Then
On Error Resume Next
If Selection.Cells.Count > 1 And Selection.Cells.Count < limit Then
On Error Resume Next
Application.StatusBar = _
" D: " & Format(WorksheetFunction.Max(Selection) - WorksheetFunction.Min(Selection), frmt) & _
" U: " & Format(Unique(Selection), frmt) & _
" 2X: " & Format(WorksheetFunction.Sum(Selection) * 2, frmt) & _
" X2: " & Format(WorksheetFunction.Sum(Selection) / 2, frmt) & _
" NC: " & Format(WorksheetFunction.CountIf(Selection, "<0"), frmt) & _
" NS: " & Format(WorksheetFunction.SumIf(Selection, "<0"), frmt)
Else
If Selection.Cells.Count = 1 Or Selection.Cells.Count >= limit Then
On Error Resume Next
Application.StatusBar = False
End If ' No condition
End If ' Cells > 2 and < limit
End If ' Areas = 1 - end of first condition
' second condition - more than one selection areas
If Selection.Areas.Count > 1 Then
Dim r1 As range
Dim r2 As range
Set r1 = Selection.Areas(1)
'WorksheetFunction.Sum (r1)
On Error Resume Next
Set r2 = Selection.Areas(2)
'Set multipleRange = Union(r1, r2)
On Error Resume Next
If Selection.Cells.Count > 1 And Selection.Cells.Count < limit Then
On Error Resume Next
Application.StatusBar = _
" D: " & Format(DIFF(r1, r2), frmt) & _
" U: " & Format(Unique(r1), frmt) & _
" 2X: " & Format(WorksheetFunction.Sum(r1) * 2, frmt) & _
" X2: " & Format(WorksheetFunction.Sum(r1) / 2, frmt) & _
" NC: " & Format(WorksheetFunction.CountIf(r1, "<0"), frmt) & _
" NS: " & Format(WorksheetFunction.SumIf(r1, "<0"), frmt)
Else
If Selection.Cells.Count = 1 Or Selection.Cells.Count >= limit Then
On Error Resume Next
Application.StatusBar = False
End If ' no condition
End If ' Cells > 1
End If ' Areas > 1 - end of second condition
End Sub
Module 1:
Public Function DIFF(rng1 As range, rng2 As range)
DIFF = WorksheetFunction.Sum(rng1) - WorksheetFunction.Sum(rng2)
End Function
Module 2:
Public Function Unique(ByRef rngToCheck As range) As Variant
Dim colDistinct As Collection
Dim varValues As Variant, varValue As Variant
Dim lngCount As Long, lngRow As Long, lngCol As Long
On Error GoTo ErrorHandler
varValues = rngToCheck.Value
'if rngToCheck is more than 1 cell then
'varValues will be a 2 dimensional array
If IsArray(varValues) Then
Set colDistinct = New Collection
For lngRow = LBound(varValues, 1) To UBound(varValues, 1)
For lngCol = LBound(varValues, 2) To UBound(varValues, 2)
varValue = varValues(lngRow, lngCol)
'ignore blank cells and throw error
'if cell contains an error value
If LenB(varValue) > 0 Then
'if the item already exists then an error will
'be thrown which we want to ignore
On Error Resume Next
colDistinct.Add vbNullString, CStr(varValue)
On Error GoTo ErrorHandler
End If
Next lngCol
Next lngRow
lngCount = colDistinct.Count
Else
If LenB(varValues) > 0 Then
lngCount = 1
End If
End If
Unique = lngCount
Exit Function
ErrorHandler:
Unique = CVErr(xlErrValue)
End Function

VBA - List of sheets (hyperlinked)

I have an Excel-Workbook. In this workbook a new sheet is created via VBA.
The more sheets this workbook has the more confusing is it, because I have to scroll a long time to reach any sheet in the middle.
I want to create an overview-sheet
in which the names of the sheets are listed AND
the name of the sheets have to be hyperlinks.
My code doesn't work at all -
BTW, I have to work with Excel 2003
Here's what I have:
Sub GetHyperlinks()
Dim ws As Worksheet
Dim i As Integer
i = 4
ActiveWorkbook.Sheets("overview").Cells(i, 1).Select
For Each ws In Worksheets
ActiveWorkbook.Sheets("overwies").Hyperlinks.Add _
Ancor:=Selection, _
Address:="", _
SubAddress:="'ws.name'", _
TextToDisplay:="'ws.name'"
i = i + 1
Next ws
End Sub
Altered your code a bit - this now works:
Sub GetHyperlinks()
Dim ws As Worksheet
Dim i As Integer
i = 4
For Each ws In ThisWorkbook.Worksheets
ActiveWorkbook.Sheets("overview").Hyperlinks.Add _
Anchor:=ActiveWorkbook.Sheets("overview").Cells(i, 1), _
Address:="", _
SubAddress:="'" & ws.Name & "'!A1", _
TextToDisplay:=ws.Name
i = i + 1
Next ws
End Sub
Two methods are used to create the links to the Active Workbook Sheets:
Simple hyperlinks are created for standard Worksheets.
Less commonly used Chart Sheets — and even rarer Dialog Sheets — cannot be hyperlinked. If this code detects a non-Worksheet type, a Sheet BeforeDoubleClick event is programmatically added to the TOC sheet so that these Sheets can still be referenced via a short cut.
Note that (2) requires that macros are enabled for this approach to work.
Option Explicit
Sub CreateTOC()
Dim ws As Worksheet
Dim nmToc As Name
Dim rng1 As Range
Dim lngProceed As Boolean
Dim bNonWkSht As Boolean
Dim lngSht As Long
Dim lngShtNum As Long
Dim strWScode As String
Dim vbCodeMod
'Test for an ActiveWorkbook to summarise
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
'Turn off updates, alerts and events
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
'If the Table of Contents exists (using a marker range name "TOC_Index") prompt the user whether to proceed
On Error Resume Next
Set nmToc = ActiveWorkbook.Names("TOC_Index")
If Not nmToc Is Nothing Then
lngProceed = MsgBox("Index exists!" & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbCritical, "Warning")
If lngProceed = vbYes Then
Exit Sub
Else
ActiveWorkbook.Sheets(Range("TOC_Index").Parent.Name).Delete
End If
End If
Set ws = ActiveWorkbook.Sheets.Add
ws.Move before:=Sheets(1)
'Add the marker range name
ActiveWorkbook.Names.Add "TOC_INDEX", ws.[a1]
ws.Name = "TOC_Index"
On Error GoTo 0
On Error GoTo ErrHandler
For lngSht = 2 To ActiveWorkbook.Sheets.Count
'set to start at A6 of TOC sheet
'Test sheets to determine whether they are normal worksheets
ws.Cells(lngSht + 4, 2).Value = TypeName(ActiveWorkbook.Sheets(lngSht))
If TypeName(ActiveWorkbook.Sheets(lngSht)) = "Worksheet" Then
'Add hyperlinks to normal worksheets
ws.Hyperlinks.Add Anchor:=ws.Cells(lngSht + 4, 1), Address:="", SubAddress:="'" & ActiveWorkbook.Sheets(lngSht).Name & "'!A1", TextToDisplay:=ActiveWorkbook.Sheets(lngSht).Name
Else
'Add name of any non-worksheets
ws.Cells(lngSht + 4, 1).Value = ActiveWorkbook.Sheets(lngSht).Name
'Colour these sheets yellow
ws.Cells(lngSht + 4, 1).Interior.Color = vbYellow
ws.Cells(lngSht + 4, 2).Font.Italic = True
bNonWkSht = True
End If
Next lngSht
'Add headers and formatting
With ws
With .[a1:a4]
.Value = Application.Transpose(Array(ActiveWorkbook.Name, "", Format(Now(), "dd-mmm-yy hh:mm"), ActiveWorkbook.Sheets.Count - 1 & " sheets"))
.Font.Size = 14
.Cells(1).Font.Bold = True
End With
With .[a6].Resize(lngSht - 1, 1)
.Font.Bold = True
.Font.ColorIndex = 41
.Resize(1, 2).EntireColumn.HorizontalAlignment = xlLeft
.Columns("A:B").EntireColumn.AutoFit
End With
End With
'Add warnings and macro code if there are non WorkSheet types present
If bNonWkSht Then
With ws.[A5]
.Value = "This workbook contains at least one Chart or Dialog Sheet. These sheets will only be activated if macros are enabled (NB: Please doubleclick yellow sheet names to select them)"
.Font.ColorIndex = 3
.Font.Italic = True
End With
strWScode = "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & vbCrLf _
& " Dim rng1 As Range" & vbCrLf _
& " Set rng1 = Intersect(Target, Range([a6], Cells(Rows.Count, 1).End(xlUp)))" & vbCrLf _
& " If rng1 Is Nothing Then Exit Sub" & vbCrLf _
& " On Error Resume Next" & vbCrLf _
& " If Target.Cells(1).Offset(0, 1) <> ""Worksheet"" Then Sheets(Target.Value).Activate" & vbCrLf _
& " If Err.Number <> 0 Then MsgBox ""Could not select sheet"" & Target.Value" & vbCrLf _
& "End Sub" & vbCrLf
Set vbCodeMod = ActiveWorkbook.VBProject.VBComponents(ws.CodeName)
vbCodeMod.CodeModule.AddFromString strWScode
End If
'tidy up Application settins
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
ErrHandler:
If Err.Number <> 0 Then MsgBox Err.Description & vbCrLf & "Please note that your Application settings have been reset", vbCritical, "Code Error!"
End Sub