Related
I have some data in my excel file and based on that data I'm using a macro for generating the report which should be saved in the place specified by path provided by the user. On my laptop, with Win10 everything is working fine, but on PC there is an error when we try to generate a report. Instead of saving the report in provided place excel is asking me to save data in "Book16" as shows the screenshot below. Do I have no idea why?
Here is the code of macro responsible for creating the report:
Sub Nationalreports()
Dim sh1 As Worksheet, N As Long
Dim st As String
Dim wbUnSaved As Workbook
Dim wbSaved As Workbook
Dim RedemptiontypeIncHdgs As Range
Dim RedemptiontypeExcHdgs As Range
Dim Fr As Long, LR As Long
Dim vaFiles As Variant
Dim i As Long
Dim wbkToCopy As Workbook
Dim ws As Worksheet, strFile As String
Dim File_path As String
Dim qry As QueryTable
Dim FilNams As Variant
Dim FilNamCntr As Long
Dim strQryName As String
Dim lastrow As Long
Application.ScreenUpdating = False
If Range("E8").Value = 0 Then
MsgBox "Please Specify FilePath", vbExclamation, "Please Specify
FilePath"
Range("E8").Activate
Exit Sub
End If
File_path = Sheets("Control").Range("E8").Value
Set wbksaved = ActiveWorkbook
MsgBox "Please Select MVRT Reports", vbInformation, "Select Files"
FilNams = Application.GetOpenFilename(FileFilter:="CSV Files
(*.csv),*.csv", _
Title:="Select Textfile to
Import", _
MultiSelect:=True)
If TypeName(FilNams) = "Boolean" Then
MsgBox "No Files Selected", vbExclamation, "No Files Selected"
Exit Sub
Else
End If
For FilNamCntr = LBound(FilNams) To UBound(FilNams)
FilNams(FilNamCntr) = "TEXT;" & FilNams(FilNamCntr)
Next FilNamCntr
For FilNamCntr = LBound(FilNams) To UBound(FilNams)
Sheets("Data").Cells.NumberFormat = "#"
Set wbkToCopy = Workbooks.Add
With ActiveSheet
If .Range("A" & Rows.Count).End(xlUp).Row = 1 Then
lastrow = 1
Else
lastrow = .Range("A" & Rows.Count).End(xlUp).Row + 1
End If
Set qry = .QueryTables.Add(Connection:=FilNams(FilNamCntr), _
Destination:=.Range("A" & lastrow))
With qry
.Name = "Filename"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End With
'-------------------------------------------------------------------------------------------
'NEW CODE:
'-------------------------------------------------------------------------------------------
'progress
'Rows("1:1").Delete
'ActiveSheet.UsedRange.Columns("A:T").SpecialCells(xlCellTypeVisible).Copy
'wbksaved.Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Offset(0).PasteSpecial Paste:=xlPasteValues
ActiveSheet.UsedRange.Columns("A:T").SpecialCells(xlCellTypeVisible).Select
Selection.Copy
'wbksaved.Sheets("Data").Activate
'Range("A1").Select
'ActiveSheet.Paste
wbksaved.Sheets("Data").Paste
'ERROR IS HERE ^^^^^^^^^^^^^
'-------------------------------
'new:
Application.CutCopyMode = False
'-------------------------------
Application.DisplayAlerts = False
ActiveWorkbook.Close False
Application.DisplayAlerts = True
Next FilNamCntr
Set wbkToCopy = Workbooks.Add
wbkToCopy.Sheets(1).Name = "Duplicates,Invalid"
wbkToCopy.Worksheets.Add().Name = "Breakdown"
wbkToCopy.Worksheets.Add().Name = "Summary"
wbksaved.Sheets("Redemption").UsedRange.Columns("C:D").Copy
Sheets("Duplicates,Invalid").Range("A1").PasteSpecial Paste:=xlPasteValues
'-------------------------------
'new:
Application.CutCopyMode = False
'-------------------------------
' Duplicates & Invalids Sheet
Sheets("Duplicates,Invalid").Activate
Columns("B").Cut Destination:=Columns("F")
Columns("A").Cut Destination:=Columns("B")
Range("B1").Value = "Duplicate Codes"
Range("F1").Value = "Invalid Codes"
Range("A2").Value = "1"
Range("A3").Value = "2"
On Error Resume Next
Cells(2, 1).AutoFill Destination:=Range("A2:A" & Range("B" & Rows.Count).End(xlUp).Row), Type:=xlFillSeries
Range("E2").Value = "1"
Range("E3").Value = "2"
On Error Resume Next
Cells(2, 5).AutoFill Destination:=Range("E2:E" & Range("F" & Rows.Count).End(xlUp).Row), Type:=xlFillSeries
Range("A1").Value = "Nr."
Range("E1").Value = "Nr."
Columns("A:F").EntireColumn.AutoFit
Columns("A:F").HorizontalAlignment = xlCenter
Cells.Interior.Pattern = xlSolid
Cells.Interior.TintAndShade = -0.0499893185216834
Range("A1:B1,E1:F1").Interior.ThemeColor = xlThemeColorLight1
Range("A:B,E:F").Borders.LineStyle = xlContinuous
Range("A1:B1,E1:F1").Font.ThemeColor = xlThemeColorDark1
Range("A1:B1,E1:F1").Font.Bold = True
Application.Goto Reference:=Range("A1"), Scroll:=True
' Breakdown Sheet
Sheets("Breakdown").Activate
Cells.NumberFormat = "#"
wbksaved.Sheets("MVRT").UsedRange.Columns("A:D").SpecialCells(xlCellTypeVisible).Copy
wbkToCopy.Sheets("Breakdown").Cells(Rows.Count, "A").End(xlUp).Offset(0).PasteSpecial xlPasteValues
wbksaved.Sheets("MVRT").UsedRange.Columns("F:F").SpecialCells(xlCellTypeVisible).Copy
wbkToCopy.Sheets("Breakdown").Cells(Rows.Count, "E").End(xlUp).Offset(0).PasteSpecial xlPasteValues
wbksaved.Sheets("MVRT").UsedRange.Columns("H:H").SpecialCells(xlCellTypeVisible).Copy
wbkToCopy.Sheets("Breakdown").Cells(Rows.Count, "F").End(xlUp).Offset(0).PasteSpecial xlPasteValues
wbksaved.Sheets("MVRT").UsedRange.Columns("N:N").SpecialCells(xlCellTypeVisible).Copy
wbkToCopy.Sheets("Breakdown").Cells(Rows.Count, "G").End(xlUp).Offset(0).PasteSpecial xlPasteValues
wbksaved.Sheets("MVRT").UsedRange.Columns("S:S").SpecialCells(xlCellTypeVisible).Copy
wbkToCopy.Sheets("Breakdown").Cells(Rows.Count, "H").End(xlUp).Offset(0).PasteSpecial xlPasteValues
wbksaved.Sheets("MVRT").UsedRange.Columns("K:K").SpecialCells(xlCellTypeVisible).Copy
wbkToCopy.Sheets("Breakdown").Cells(Rows.Count, "I").End(xlUp).Offset(0).PasteSpecial xlPasteValues
wbksaved.Sheets("MVRT").UsedRange.Columns("J:J").SpecialCells(xlCellTypeVisible).Copy
wbkToCopy.Sheets("Breakdown").Cells(Rows.Count, "J").End(xlUp).Offset(0).PasteSpecial xlPasteValues
wbksaved.Sheets("MVRT").UsedRange.Columns("M:M").SpecialCells(xlCellTypeVisible).Copy
wbkToCopy.Sheets("Breakdown").Cells(Rows.Count, "K").End(xlUp).Offset(0).PasteSpecial xlPasteValues
wbksaved.Sheets("MVRT").UsedRange.Columns("Q:Q").SpecialCells(xlCellTypeVisible).Copy
ActiveSheet.Paste Destination:=Worksheets("Breakdown").Range("L:L")
'-------------------------------
'new:
Application.CutCopyMode = False
'-------------------------------
'Range("O:P").Delete
Range("A1").Value = "UUID"
Range("B1").Value = "Security Code"
Range("C1").Value = "Customer Code"
Range("D1").Value = "Country Code"
Range("E1").Value = "Salesforce Id"
Range("F1").Value = "Merchant Name"
Range("G1").Value = "Unit Status"
Range("H1").Value = "Redemption Status"
Range("I1").Value = "Expires At"
Range("J1").Value = "Expired"
Range("K1").Value = "Suspended"
Range("L1").Value = "Redemption Date"
'Range("M:M").Replace What:="Invalid Rights", Replacement:="Other Country"
Range("B:L").Sort Key1:=Range("I:I"), Order1:=xlAscending, Header:=xlYes
Range("A:L").EntireColumn.AutoFit
Range("A1:L1").HorizontalAlignment = xlCenter
Cells.Interior.Pattern = xlSolid
Cells.Interior.TintAndShade = -0.0499893185216834
Range("A1:L1").Interior.ThemeColor = xlThemeColorLight1
Range("A:L").Borders.LineStyle = xlContinuous
Range("A1:L1").Font.ThemeColor = xlThemeColorDark1
Rows("1:1").Font.Bold = True
Application.Goto Reference:=Range("A1"), Scroll:=True
'Summary Sheet
Sheets("Summary").Activate
Range("C9").Value = "Country"
Range("C10").Value = "Merchant Name"
Range("C11").Value = "Type"
Range("C16").Value = "Redemption Type"
Range("C17").Value = "Invalid"
Range("C18").Value = "Duplicates"
Range("C19").Value = "Suspended"
Range("C20").Value = "Voucher Expired"
Range("C21").Value = "Payment Invalid"
Range("C22").Value = "Payment Refunded"
Range("C23").Value = "Redeemed"
Range("C24").Value = "Total Codes Sent In"
Range("D9").FormulaR1C1 = "=Breakdown!R[-7]C[0]"
Range("D10").FormulaR1C1 = "=Breakdown!R[-8]C[2]"
Range("D11").FormulaR1C1 = "Offsite Redemptions"
Range("D16").FormulaR1C1 = "No."
Range("D17").FormulaR1C1 = "=COUNTA('Duplicates,Invalid'!C[2])-1"
Range("D18").FormulaR1C1 = "=COUNTA('Duplicates,Invalid'!C[-2])-1"
Range("D19").Formula = "=COUNTIFS(Breakdown!K:K,""*true*"",Breakdown!H:H,""*Forced redeemable*"")"
'Range("D19").AutoFill Destination:=Range("D19:D25"), Type:=xlFillCopy
Range("D20").Formula = "=COUNTIFS(Breakdown!J:J,""*true*"",Breakdown!K:K,""*false*"",Breakdown!G:G,""*collected*"",Breakdown!H:H,""*Forced redeemable*"")"
'payment not received:
Range("D21").Formula = "=COUNTIFS(Breakdown!K:K,""*false*"",Breakdown!G:G,""*resigned*"",Breakdown!H:H,""*Forced redeemable*"") + COUNTIFS(Breakdown!K:K,""*false*"",Breakdown!G:G,""*pending*"",Breakdown!H:H,""*Forced redeemable*"")"
'payment refunded:
Range("D22").Formula = "=COUNTIFS(Breakdown!G:G,""*deleted*"",Breakdown!K:K,""*false*"",Breakdown!H:H,""*Forced redeemable*"")"
Range("D23").Formula = "=COUNTIF(Breakdown!H:H,""*redeemed*"")"
'sum-formula:
Range("D24").Formula = "=COUNTA(Breakdown!A:A)-1 + SUM(D17:D18)"
Range("C:D").Copy
Range("C:C").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range("A:B,E:F").ColumnWidth = 26
Range("C:D").ColumnWidth = 63.29
Range("C:D").HorizontalAlignment = xlCenter
Cells.Interior.Pattern = xlSolid
Cells.Interior.TintAndShade = -0.0499893185216834
Range("C1:D5,C9:C11,C16:D16,C24:D24").Interior.ThemeColor =
xlThemeColorLight1
Range("D9:D11,C16:D24").Borders.LineStyle = xlContinuous
Range("C9:C11,C16:D16,C24:D24").Font.ThemeColor = xlThemeColorDark1
Range("C9:D11,C16:D24").Font.Bold = True
Range("C3:D3").Merge True
Dim myR As Range
Set myR = Range("C3:D3")
wbksaved.Sheets("Control").Shapes("Groupon Logo").Copy
Range("C3:D3").PasteSpecial xlPasteFormats
'-------------------------------
'new:
Application.CutCopyMode = False
'-------------------------------
Selection.ShapeRange.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.IncrementLeft (myR.Width - Selection.ShapeRange.Width) / 2
Application.Goto Reference:=Range("A1"), Scroll:=True
Country = Range("D9").Value
'Merchant_ID = Range("D10").Value This was DELETED on Lorene request
Merchant_Name = Range("D10").Value
dt = Format(CStr(Now), "dd_mm_yyyy_hh_mm_ss")
File_Name = File_path & "\" & "Report" & " " & Merchant_Name & " " &
Merchant_ID & " " & dt & ".xlsx"
ActiveWorkbook.SaveAs Filename:=File_Name, FileFormat:=51
ActiveWorkbook.Close
Application.DisplayAlerts = False
Sheets("Data").Cells.Delete
Application.DisplayAlerts = True
Sheets("Control").Select
MsgBox "Report Created", vbInformation, "Report Created"
Application.ScreenUpdating = True
End Sub
Can you try instead of this:
ActiveSheet.UsedRange.Columns("A:T").SpecialCells(xlCellTypeVisible).Select
Selection.Copy
wbksaved.Sheets("Data").Paste
To write this:
ActiveSheet.Columns("A:T").SpecialCells(xlCellTypeVisible).Copy
wbksaved.Sheets("Data").Range("A1").Paste
And to see whether the "error" would still exist? In general, Selection.Copy and ActiveSheet, ActiveCell should be avoided whenever possible - How to avoid using Select in Excel VBA
When using the code below to reference a worksheet by codename, I get file explorer opening up for each instance of the "Sheet34". How can I prevent this?
Private Sub CheckBox4_Click()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim sheetName As String
If CheckBox4.Value = True Then
ActiveWorkbook.Unprotect
Worksheets("SUMMARY").Unprotect
sheetName = Sheets("Control").Cells(16, "I")
If sheetName = "" Then
MsgBox "You must enter a valid Allowance descriptor. No entry was detected."
CheckBox4.Value = False
Exit Sub
End If
If Len(sheetName) > 31 Then
MsgBox "Worksheet tab names cannot be greater than 31 characters in length."
Application.EnableEvents = False
Sheets("Control").Cells(16, "I").ClearContents
Application.EnableEvents = True
CheckBox4.Value = False
Exit Sub
End If
Dim IllegalCharacter(1 To 7) As String, i As Integer
IllegalCharacter(1) = "/"
IllegalCharacter(2) = "\"
IllegalCharacter(3) = "["
IllegalCharacter(4) = "]"
IllegalCharacter(5) = "*"
IllegalCharacter(6) = "?"
IllegalCharacter(7) = ":"
For i = 1 To 7
If InStr(sheetName, (IllegalCharacter(i))) > 0 Then
MsgBox "You used a character that violates sheet naming rules. Please refrain from the following characters: / \ [ ] * ? : "
Application.EnableEvents = False
Sheets("Control").Cells(16, "I").ClearContents
Application.EnableEvents = True
CheckBox4.Value = False
Exit Sub
End If
Next i
If Sheets("Control").Range("I16") = Sheets("Control").Range("I17") Then
MsgBox "There is already an Allowance with this name. Please choose a different name."
Application.EnableEvents = False
Sheets("Control").Cells(16, "I").ClearContents
Application.EnableEvents = True
CheckBox4.Value = False
Exit Sub
End If
If Sheets("Control").Range("I16") = Sheets("Control").Range("I18") Then
MsgBox "There is already an Allowance with this name. Please choose a different name."
Application.EnableEvents = False
Sheets("Control").Cells(16, "I").ClearContents
Application.EnableEvents = True
CheckBox4.Value = False
Exit Sub
End If
If Sheets("Control").Range("I16") = Sheets("Control").Range("I21") Then
MsgBox "There is already an Other Item with this name. Please choose a different name."
Application.EnableEvents = False
Sheets("Control").Cells(16, "I").ClearContents
Application.EnableEvents = True
CheckBox4.Value = False
Exit Sub
End If
If Sheets("Control").Range("I16") = Sheets("Control").Range("I22") Then
MsgBox "There is already an Other Item with this name. Please choose a different name."
Application.EnableEvents = False
Sheets("Control").Cells(16, "I").ClearContents
Application.EnableEvents = True
CheckBox4.Value = False
Exit Sub
End If
If Sheets("Control").Range("I16") = Sheets("Control").Range("I23") Then
MsgBox "There is already an Other Item with this name. Please choose a different name."
Application.EnableEvents = False
Sheets("Control").Cells(16, "I").ClearContents
Application.EnableEvents = True
CheckBox4.Value = False
Exit Sub
End If
If WorksheetExists(sheetName) Then
Worksheets(sheetName).Visible = -1
Worksheets("SUMMARY").Rows("47").EntireRow.Hidden = False
Worksheets("SUMMARY").Cells(47, 2).Value = "ALL 1:"
Worksheets("SUMMARY").Cells(47, 3).Value = "='Control'!I16"
Worksheets("SUMMARY").Cells(47, 3).NumberFormat = "General"
Worksheets("SUMMARY").Cells(47, 4).Value = "='Control'!K16"
Worksheets("SUMMARY").Cells(47, 5).Value = "='Control'!L16"
Worksheets("SUMMARY").Cells(47, 6).Value = "=" & sheetName & "!$H$69"
Worksheets("SUMMARY").Cells(47, 7).Value = "=" & sheetName & "!$J$69"
Worksheets("SUMMARY").Cells(47, 8).Value = "=" & sheetName & "!$N$69"
Worksheets("SUMMARY").Cells(47, 9).Value = "=" & sheetName & "!$P$69"
Worksheets("SUMMARY").Cells(47, 10).Value = "=SUM(F47:I47)/D47"
Worksheets("SUMMARY").Cells(47, 11).Value = "=L47/F3"
Worksheets("SUMMARY").Cells(47, 12).Value = "=" & sheetName & "!$U$69"
Worksheets("SUMMARY").Cells(47, 13).Value = "=L47/$K$57"
ActiveWorkbook.Protect
Sheets(sheetName).Protect
Sheets("SUMMARY").Protect
Exit Sub
Else
Set ws = ActiveWorkbook.Sheet34
ws.Name = sheetName
ws.Protect
ws.EnableSelection = xlUnlockedCells
Application.CutCopyMode = False
Worksheets("SUMMARY").Rows("47").EntireRow.Hidden = False
Worksheets("SUMMARY").Cells(47, 2).Value = "ALL 1:"
Worksheets("SUMMARY").Cells(47, 3).Value = "='Control'!I16"
Worksheets("SUMMARY").Cells(47, 3).NumberFormat = "General"
Worksheets("SUMMARY").Cells(47, 4).Value = "='Control'!K16"
Worksheets("SUMMARY").Cells(47, 5).Value = "='Control'!L16"
Worksheets("SUMMARY").Cells(47, 6).Value = "=" & ws.Name & "!$H$69"
Worksheets("SUMMARY").Cells(47, 7).Value = "=" & ws.Name & "!$J$69"
Worksheets("SUMMARY").Cells(47, 8).Value = "=" & ws.Name & "!$N$69"
Worksheets("SUMMARY").Cells(47, 9).Value = "=" & ws.Name & "!$P$69"
Worksheets("SUMMARY").Cells(47, 10).Value = "=SUM(F47:I47)/D47"
Worksheets("SUMMARY").Cells(47, 11).Value = "=L47/F3"
Worksheets("SUMMARY").Cells(47, 12).Value = "=" & ws.Name & "!$U$69"
Worksheets("SUMMARY").Cells(47, 13).Value = "=L47/$K$57"
ActiveWorkbook.Protect
Sheets(sheetName).Protect
Sheets("SUMMARY").Protect
Worksheets("Control").Activate
End If
End If
If CheckBox4.Value = False Then
ActiveWorkbook.Unprotect
Worksheets("SUMMARY").Unprotect
sheetName = Sheets("Control").Cells(16, "I")
If WorksheetExists(sheetName) Then
Worksheets(sheetName).Visible = 2
Worksheets("SUMMARY").Rows("47").EntireRow.ClearContents
Worksheets("SUMMARY").Rows("47").EntireRow.Hidden = True
ActiveWorkbook.Protect
Sheets(sheetName).Protect
Sheets("SUMMARY").Protect
End If
End If
Application.ScreenUpdating = True
End Sub
Follow up question: This code is taking an existing sheet and renaming it. The concern I have is if the user names the sheet in Cell I16, then renames it, and unchecks or checks the box, I get a row on the Summary Worksheet with poor references. Also, the code will not allow me to enter the code below
Worksheets("SUMMARY").Cells(47, 6).Value = "=" & sheetName & "!$H$69"
as
Worksheets("SUMMARY").Cells(47, 6).Value = "="' & sheetName & '"!$H$69"
as it turns the & sheetName & into a comment. How can I fix this so that the worksheet is properly referenced in the code? Do I need to keep with the codename worksheet?
My thoughts on how to stop the renaming issue was to protect the named cell so long as the checkbox value is positive, and allow the user to edit the cell if the checkbox value is false; maybe adding a line of code that checks if the cell is being changed and asking the user if they are sure this is the cell they want to modify, which would clear the data, but not the formatting, of the existing spreadsheet.
You are trying to set the value of a cell to a formula...Try out the following:
Create a direct link to a cell in another sheet within the same workbook
Open another workbook.
Create a direct link to a cell in a sheet from the other workbook
You will find that the following would be correct use for a worksheet reference:
Worksheets("SUMMARY").Cells(47, 6).Formula = "='" & sheetName & "'!$H$69"
And the below for a workbook reference:
Worksheets("SUMMARY").Cells(47, 6).Formula = "='[" & Worboookpath & "] & sheetName & "'!$H$69"
I have designed a code that creates a new worksheet based on a checkbox, and the name is derived from a User Defined Variable. However, if someone unchecks and checks the box, it runs the code again and generates an error due to multiple worksheets having the same name. I understand that this is just the code functioning as it is supposed to, but I want to create an IF:THEN statement where the code checks to see if the name exists. If the sheet exists, the code will do stop itself; if the sheet does not exist, it will run as normal.
How can I do this?
Code below.
Private Sub CheckBox4_Click()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Protocol As Range
If CheckBox4.Value = True Then
ActiveWorkbook.Unprotect
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
ws.Name = Sheets("Control").Cells(16, "I")
Set Protocol = Sheets("The Hidden Works").Columns("W:AQ").EntireColumn
Protocol.Copy
ws.Paste
ws.Protect
ws.EnableSelection = xlUnlockedCells
Application.CutCopyMode = False
Worksheets("SUMMARY").Rows("44").EntireRow.Hidden = False
Worksheets("SUMMARY").Cells(44, 3).Value = "='Control'!I16"
Worksheets("SUMMARY").Cells(44, 3).NumberFormat = "General"
Worksheets("SUMMARY").Cells(44, 4).Value = "='Control'!K16"
Worksheets("SUMMARY").Cells(44, 5).Value = "='Control'!L16"
Worksheets("SUMMARY").Cells(44, 6).Value = "=" & ws.Name & "!$H$69"
Worksheets("SUMMARY").Cells(44, 7).Value = "=" & ws.Name & "!$J$69"
Worksheets("SUMMARY").Cells(44, 8).Value = "=" & ws.Name & "!$N$69"
Worksheets("SUMMARY").Cells(44, 9).Value = "=" & ws.Name & "!$P$69"
Worksheets("SUMMARY").Cells(44, 10).Value = "=SUM(F44:I44)/D44"
Worksheets("SUMMARY").Cells(44, 11).Value = "=M44/F3"
Worksheets("SUMMARY").Cells(44, 12).Value = "=" & ws.Name & "!$U$69"
Worksheets("SUMMARY").Cells(44, 13).Value = "=M44/$K$57"
Worksheets("Control").Activate
End If
Application.ScreenUpdating = True
End Sub
You can evaluate if a cell exists on the specifically named sheet to check:
Application.DisplayAlerts = False
If IsError(Evaluate("SHEETNAME!A1")) Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = "SHEETNAME"
Application.DisplayAlerts = True
You can use the below function to check if a Sheet exists:
Function WorksheetExists(sheetName As String) As Boolean
WorksheetExists = Evaluate("ISREF('" & sheetName & "'!A1)")
End Function
Use it like,
If WorksheetExists("Sheet10") Then
Exit Sub
Else
'Your Code
End If
Your code adapted to use the solution:
Private Sub CheckBox4_Click()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Protocol As Range
Dim sheetName As String
If CheckBox4.Value = True Then
ActiveWorkbook.Unprotect
sheetName = Sheets("Control").Cells(16, "I")
If WorksheetExists(sheetName) Then
Exit Sub
Else
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
ws.Name = sheetName
Set Protocol = Sheets("The Hidden Works").Columns("W:AQ").EntireColumn
Protocol.Copy
ws.Paste
ws.Protect
ws.EnableSelection = xlUnlockedCells
Application.CutCopyMode = False
Worksheets("SUMMARY").Rows("44").EntireRow.Hidden = False
Worksheets("SUMMARY").Cells(44, 3).Value = "='Control'!I16"
Worksheets("SUMMARY").Cells(44, 3).NumberFormat = "General"
Worksheets("SUMMARY").Cells(44, 4).Value = "='Control'!K16"
Worksheets("SUMMARY").Cells(44, 5).Value = "='Control'!L16"
Worksheets("SUMMARY").Cells(44, 6).Value = "=" & ws.Name & "!$H$69"
Worksheets("SUMMARY").Cells(44, 7).Value = "=" & ws.Name & "!$J$69"
Worksheets("SUMMARY").Cells(44, 8).Value = "=" & ws.Name & "!$N$69"
Worksheets("SUMMARY").Cells(44, 9).Value = "=" & ws.Name & "!$P$69"
Worksheets("SUMMARY").Cells(44, 10).Value = "=SUM(F44:I44)/D44"
Worksheets("SUMMARY").Cells(44, 11).Value = "=M44/F3"
Worksheets("SUMMARY").Cells(44, 12).Value = "=" & ws.Name & "!$U$69"
Worksheets("SUMMARY").Cells(44, 13).Value = "=M44/$K$57"
Worksheets("Control").Activate
End If
End If
Application.ScreenUpdating = True
End Sub
Function WorksheetExists(sheetName As String) As Boolean
WorksheetExists = Evaluate("ISREF('" & sheetName & "'!A1)")
End Function
Similar to in this question https://stackoverflow.com/questions/ask/advice?. I would like to copy and paste values but am receiving a Run-Time Error 438: Object does not support this property or method. Unfortunately I am not doing my copy and paste in the same way as this other person so the answers do not apply to me
Sub precipitation()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim directory As String, fileName As String
directory = "C:\Working-Directory\Precipdata\"
fileName = Dir(directory & "*.csv")
Do While fileName <> ""
sheetName = Left(fileName, Len(fileName) - 4)
Workbooks.Open (directory & fileName)
Workbooks(fileName).Activate
If Range("B1").Value = "GJOA HAVEN A" Then
col = "B"
End If
If Range("B1").Value = "TALOYOAK A" Then
col = "E"
End If
If Range("B1").Value = "GJOA HAVEN CLIMATE" Then
col = "H"
End If
If Range("B1").Value = "HAT ISLAND" Then
col = "K"
End If
If Range("B1").Value = "BACK RIVER (AUT)" Then
col = "N"
End If
yr = Range("B27").Value
lngth = (Range("B27").End(xlDown).Row)
Workbooks("Macroforprecip.xlsm").Activate
Set rw = ActiveSheet.Cells.Find(what:=DateValue("01/01/" & yr))
r = rw.Row
Workbooks(fileName).Worksheet(sheetName).Range("P27", "P" & lngth).Copy Workbooks("Macroforprecip.xlsm").Worksheets("Sheet1").Range(col & r)
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
My error comes on the Workbooks(fileName).Range("P27", "P" & lngth).Copy _
Workbooks("Macroforprecip.xlsm").Range(col & r) line
Thank you
replace:
Workbooks(fileName).Worksheet(sheetName).Range("P27", "P" & lngth).Copy Workbooks("Macroforprecip.xlsm").Worksheets("Sheet1").Range(col & r)
with:
Workbooks(fileName).Activate
Workbooks(fileName).Worksheet(sheetName).Range("P27", "P" & lngth).Select
Selection.Copy
Workbooks("Macroforprecip.xlsm").Activate
worksheets("Sheet1").Activate
Range(col & r).Select
ActiveSheet.Paste
I have a relatively long set of subs that get run on a list of my excel files a few times a day. after a few runs, the file then becomes corrupted which normally would not be an issue b/c it doesn't really effect any of the data. however, I have another program that opens up each of the excel and pulls some key data from each one to make a summary sheet. because the corrupted file gives a message that says something along the lines of "there is a problem with some of your content" the summary program stops with a
run-time error '1004': Method of object 'Workbooks' Failed
I can not for the life of me figure out what in my code is causing the corruption. Is there a way I can have the summary code ignore the corruption notification? Ive tried a handful of different things including turning the application notifications off in my code to no avail.
Any help is greatly appreciated! ill post my all my code with a brief description below:
Here is the code from the summary file that opens each of the
individual files and pulls data:
Sub OEEsummmary()
Dim ActCycCell, ExpCycCell, ExpCurCycCell, ShiftCell, DifCell, DownCell, DTResACell, DTResBCell, PartCell, OpNamCell, OprCell, RejCell, RejResCell As Range
Dim MySheet As Worksheet
Dim Txt$, MyPath$, MyWB$
Dim myValue As Integer
Dim x As Long
Dim v As Variant, r As Range, rWhere As Range
MyPath = "L:\Manufacturing Engineering\Samuel Hatcher\"
x = 2
Set MySheet = ActiveSheet
'Application.ScreenUpdating = False
Application.EnableEvents = False
MySheet.Range("B2:G18").ClearContents
MySheet.Range("J2:O18").ClearContents
Do While MySheet.Range("A" & x).Value <> ""
MyWB = MySheet.Range("A" & x).Text
Workbooks.Open Filename:=MyPath & MyWB, ReadOnly:=True, IgnoreReadOnlyRecommended:=True
Set ActCycCell = ActiveSheet.Range("E21")
Set ExpCycCell = ActiveSheet.Range("D21")
Set ShiftCell = ActiveSheet.Range("E2")
Set DownCell = ActiveSheet.Range("K28")
Set DTResACell = ActiveWorkbook.Worksheets("Downtime").Range("O9")
Set DTResBCell = ActiveWorkbook.Worksheets("Downtime").Range("O10")
Set PartCell = ActiveSheet.Range("E4")
Set ExpCurCycCell = ActiveSheet.Range("D22")
If ActiveSheet.Range("I3") = "" Then
Set OpNamCell = ActiveSheet.Range("I2")
Else
Set OpNamCell = ActiveSheet.Range("I3")
End If
Set OprCell = ActiveSheet.Range("C4")
Set RejCell = ActiveSheet.Range("H21")
Set RejResCell = ActiveWorkbook.Worksheets("Rejected Parts").Range("H5")
With MySheet.Range("A" & x)
.Offset(0, 14).Value = OprCell.Value
.Offset(0, 13).Value = OpNamCell.Value
.Offset(0, 12).Value = PartCell.Value
.Offset(0, 11).Value = ShiftCell.Value
.Offset(0, 10).Value = RejResCell.Value
.Offset(0, 9).Value = RejCell.Value
.Offset(0, 6).Value = ActCycCell.Value
.Offset(0, 5).Value = ExpCycCell.Value
.Offset(0, 4).Value = ExpCurCycCell.Value
.Offset(0, 3).Value = DTResBCell.Value
.Offset(0, 2).Value = DTResACell.Value
.Offset(0, 1).Value = DownCell.Value
End With
ActiveWorkbook.Close savechanges:=False
x = x + 1
Loop
Call sort
'Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Clears the page of data to prepare it for a new shift of entering
data:
Sub ClearFrontEnd()
Sheets("Front End").Unprotect ("29745")
'prompts user to confirm if they realy want to clear entry
response = MsgBox("Are You Sure?", vbYesNo)
If response = vbNo Then
Exit Sub
End If
'checks to see if operator number is there
If range("I3").Value = "" Then
MsgBox "ENTER OPORATOR # AND CLICK NEW SHIFT AGAIN"
Else
Call StopTimer
Call prodChoose
Call transfer
Application.ScreenUpdating = False
ActiveWorkbook.Save
Sheets("Front End").Unprotect ("29745")
Sheets("Front End").Select
'Deletes the data from the entry and unique key fields
range("E8:E20").ClearContents
range("I8:I27").ClearContents
range("J8:J27").ClearContents
range("K8:K27").ClearContents
range("I3").ClearContents
range("H8").Value = ""
range("H9").Value = ""
range("H10").Value = ""
range("H11").Value = ""
range("H12").Value = ""
range("H13").Value = ""
range("H14").Value = ""
range("H15").Value = ""
range("H16").Value = ""
range("H17").Value = ""
range("H18").Value = ""
range("H19").Value = ""
range("H20").Value = ""
range("A1").Select
MsgBox "Please enter the correct values for SHIFT #, SHIFT LENGTH, PART #, AND OPORATOR #, Thanks! Have a great day!!"
End If
Sheets("Front End").Protect ("29745")
Call timerchoose
Application.ScreenUpdating = True
End Sub
This copies the data from the front page to a raw data sheet every
hour:
Sub transfer()
Sheets("Front End").Unprotect ("29745")
Application.ScreenUpdating = False
Dim x As Long
Dim v As Variant, r As range, rWhere As range
'set starting point at row 8
x = 8
'defines the sheet the data is being coppied from and pasted to
Dim sourceSheet As Worksheet: Set sourceSheet = ThisWorkbook.Worksheets("Front End")
Dim destSheet As Worksheet: Set destSheet = ThisWorkbook.Worksheets("Raw Data")
If sourceSheet.range("I3").Value = "" Then
Call StartTimer
Exit Sub
Else
Do While range("L" & x).Value <> ""
'Checks if the unique code is in the raw data sheet or not
v = sourceSheet.range("M" & x).Value
Set rWhere = destSheet.range("S:S")
Set r = rWhere.Find(what:=v, After:=rWhere(1))
If r Is Nothing Then
'selects the next row where the 1st column is empty
lMaxRows = destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Row
'pastes the data from the specified cells into the next empty row
destSheet.range("A" & lMaxRows + 1).Value = sourceSheet.range("C2").Value
destSheet.range("M" & lMaxRows + 1).Value = sourceSheet.range("E2").Value
destSheet.range("N" & lMaxRows + 1).Value = sourceSheet.range("E4").Value
destSheet.range("P" & lMaxRows + 1).Value = sourceSheet.range("G4").Value
destSheet.range("Q" & lMaxRows + 1).Value = sourceSheet.range("C4").Value
destSheet.range("O" & lMaxRows + 1).Value = sourceSheet.range("I3").Value
destSheet.range("B" & lMaxRows + 1).Value = sourceSheet.range("J" & x).Value
destSheet.range("C" & lMaxRows + 1).Value = sourceSheet.range("K" & x).Value
destSheet.range("D" & lMaxRows + 1).Value = sourceSheet.range("L" & x).Value
destSheet.range("E" & lMaxRows + 1).Value = sourceSheet.range("I" & x).Value
destSheet.range("S" & lMaxRows + 1).Value = sourceSheet.range("M" & x).Value
x = x + 1
Else
x = x + 1
End If
Loop
x = 8
Do While range("D" & x).Value <> 0
If range("E" & x).Value <> "" Then
'Checks if the unique code is in the raw data sheet or not
v = sourceSheet.range("A" & x).Value
Set rWhere = destSheet.range("S:S")
Set r = rWhere.Find(what:=v, After:=rWhere(1))
If r Is Nothing Then
'selects the next row where the 1st column is empty
lMaxRows = destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Row
'pastes the data from the specified cells into the next empty row
destSheet.range("A" & lMaxRows + 1).Value = sourceSheet.range("C2").Value
destSheet.range("M" & lMaxRows + 1).Value = sourceSheet.range("E2").Value
destSheet.range("N" & lMaxRows + 1).Value = sourceSheet.range("E4").Value
destSheet.range("P" & lMaxRows + 1).Value = sourceSheet.range("G4").Value
destSheet.range("Q" & lMaxRows + 1).Value = sourceSheet.range("C4").Value
destSheet.range("O" & lMaxRows + 1).Value = sourceSheet.range("I3").Value
destSheet.range("B" & lMaxRows + 1).Value = sourceSheet.range("B" & x).Value
destSheet.range("L" & lMaxRows + 1).Value = sourceSheet.range("C" & x).Value
destSheet.range("F" & lMaxRows + 1).Value = sourceSheet.range("D" & x).Value
destSheet.range("G" & lMaxRows + 1).Value = sourceSheet.range("E" & x).Value
destSheet.range("I" & lMaxRows + 1).Value = sourceSheet.range("G" & x).Value
destSheet.range("K" & lMaxRows + 1).Value = sourceSheet.range("H" & x).Value
destSheet.range("H" & lMaxRows + 1).Value = sourceSheet.range("N" & x).Value
destSheet.range("J" & lMaxRows + 1).Value = sourceSheet.range("O" & x).Value
destSheet.range("S" & lMaxRows + 1).Value = sourceSheet.range("A" & x).Value
x = x + 1
Else
x = x + 1
End If
Else
x = x + 1
End If
Loop
'sorts Raw Data table after new data is added
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Raw Data")
'specifies how to sort the data
With ws.Sort.SortFields
.Clear
.add Key:=ws.range("A2:A" & lMaxRows + 1), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.add Key:=ws.range("B2:B" & lMaxRows + 1), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
'specifies range over which to sort
End With
With ws.Sort
.SetRange ws.range("A1:S" & lMaxRows + 1)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
Sheets("Front End").Protect ("29745")
Call SortDTWeek
Call SortDTMonth
Call StartTimer
Application.ScreenUpdating = True
End Sub
This checks a few cells constantly to see if they have been double
clicked, if so it puts the current time in that cell
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As range, cancel As Boolean)
'Adds downtime start and finish values
'Check to see if the click/selected cell is in columns I or J
If Not Intersect(Target, range("J:K")) Is Nothing Then
'Make sure cell is in range
If Target.Row > 7 And Target.Row <= 27 Then
'Update the value
Target.Value = Time()
End If
End If
End Sub
Checks to see if a set of cells has been changed, if so it puts the
now() value in a corresponding "key" column
Private Sub Worksheet_Change(ByVal Target As range)
Sheets("Front End").Unprotect ("29745")
Dim cell As range
'Adds unique keyA values
'Check to see if the changed cell is in column E
If Not Intersect(Target, range("E:E")) Is Nothing Then
For Each cell In Target.Cells
If cell.Value <> vbNullString And Target.Row > 7 And Target.Row <= 20 Then
'Update the "KeyA" value
Sheets("Front End").range("A" & Target.Row).Value = Now()
End If
Next cell
Else
'Adds unique keyB values
'Check to see if the changed cell is in column K
If Not Intersect(Target, range("K:K")) Is Nothing Then
For Each cell In Target.Cells
If cell.Value <> vbNullString And (Target.Row > "6" And Target.Row <= "27") Then
'Update the "KeyM" value
range("M" & Target.Row).Value = Now()
End If
Next cell
End If
End If
Sheets("Front End").Unprotect ("29745")
End Sub
thanks for any input this issue has been driving me crazy
as #MLind suggested in the comments, to bypass the corrupted file error and pull some data out i added this to my code:
Workbooks.Open Filename:=MyPath & MyWB, ReadOnly:=True, IgnoreReadOnlyRecommended:=True,
CorruptLoad:=xlExtractData
and used
Application.DisplayAlerts = False
within the loop to prevent any pop up boxes from stopping the sub