I have the following code to print a specific header to each page I want to print. It takes quite some time before I can print because it regenerates over 40 sheets. Above that the project number never changes, somehow the old project number (F6) keeps in front of the new value of F6.
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim WS As Worksheet
For Each WS In Worksheets
Application.PrintCommunication = False
With ActiveSheet.PageSetup.LeftHeaderPicture
.Filename = "I:\Logo.png"
.Height = 40
.Width = 150
End With
ActiveSheet.PageSetup.LeftHeader = "&G" & vbCr & "" & vbCr & "&10Project: " & Worksheets(1).Range("F6").Text
ActiveSheet.PageSetup.RightHeader = "p. "
Application.PrintCommunication = True
Next WS
End Sub
Try this:
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim WS As Worksheet
Application.PrintCommunication = False
For Each WS In Worksheets
With WS.PageSetup.LeftHeaderPicture
.Filename = "I:\Logo.png"
.Height = 40
.Width = 150
End With
WS.PageSetup.LeftHeader = "&G" & vbCr & vbCr & _
"&10Project: " & Worksheets(1).Range("F6").Text
WS.PageSetup.RightHeader = "p. "
Next WS
Application.PrintCommunication = True
End Sub
Related
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
I am developing a user form as you can see below
enter image description here
the code in the Browse Button is
Private Sub Browse_Click()
Dim fName As String
fName = Application.GetOpenFilename("CSV File (*.csv), *.csv", , "Import .CSV File", , False)
If Not fName = "False" Then
TextBox1.Value = fName
End If
End Sub
Next step is to choose some of these options and the code behind it is
Private Sub Start_Click()
Dim Actsheet As String
Dim wkbCrntWorkBook As Workbook
Dim wkbSourceBook As Workbook
Dim rngSourceRange As Range
Dim rngDestination As Range
Set wkbCrntWorkBook = ActiveWorkbook
Set rngDestination = wkbCrntWorkBook.ActiveSheet.Range("A1:A1")
If myBeforeImprovements = True Then
Actsheet = "Before "
ElseIf AfterImprovements = True Then
Actsheet = "After "
Else
MsgBox ("Select Type of Analysis")
Exit Sub
End If
If Westbound = True Then
Actsheet = Actsheet & "WB"
ElseIf Northbound = True Then
Actsheet = Actsheet & "NB"
ElseIf Eastbound = True Then
Actsheet = Actsheet & "EB"
ElseIf Southbound = True Then
Actsheet = Actsheet & "SB"
Else
MsgBox ("Select Traffic Bound")
Exit Sub
End If
my problem is I can't take the CSV file to its write sheet which are
Before EB
Before WB
Before NB
Before SB
After EB
After WB
After NB
After SB
maybe the following code will refer to the selected CSV file but it gives me an error
Workbooks.OpenText Filename:=TextBox1.Text + "," + ComboBox1.Value + ".txt", _
DataType:=xlDelimited, Tab:=True
Replace + with & and it'll hopefully work better. The concatenation operator is & in VBA
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!
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
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