Excel VBA - Save changes to "Book16" error - vba

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

Related

Keep Receiving a 424 Debug Error w/ File Name

Please see the bold code below. The debugger says that it is what's causing the 424 "Object Required" error. Any insight/help on this would be greatly appreciated.
Sub GraywolfPlanful()
Dim sForecastFile, sUploadFile, sTab As String
Dim i As Integer
Application.ScreenUpdating = False
sForecastFile = GraywolfWorkbook.Name
Workbooks.Add
sUploadFile = GraywolfWorkbook.Name
Range("A1") = "Company"
Range("B1") = "Department"
Range("C1") = "Location"
Range("D1") = "Segment"
Range("E1") = "Account"
Range("F1") = "Year"
Range("G1") = "Month"
Range("H1") = "Amount"
Range("A2").Select
Windows(sForecastFile).Activate
sTab = Format(Sheets("00_No Department").Range("C1"), "yyyy-mm mmm") & "Project Forecast"
For i = 4 To Sheets.Count
Sheets(i).Select
Range("F6").Select
Do Until (Range("C") = "End" And Range("D") = "Subtotal Other G&A")
If Range("Z" & ActiveCell.Row) <> "" Then
Range("Z" & ActiveCell.Row, "AD" & ActiveCell.Row).Copy
Windows(sUploadFile).Activate
Range(ActiveCell, ActiveCell.Offset(12, 0)).PasteSpecial xlPasteValues
Range("B" & ActiveCell.Row, "B" & ActiveCell.Row + 12) = "Test"
Windows(sCurrentFile).Activate
End If
Loop
Next i
Windows(sUploadFile).Activate
GraywolfWorkbook.SaveAs CurDir & "\Test File Graywolf"
Application.ScreenUpdating = True
End Sub

Hyperlink with spaces

I have a worksheets for my projects.
the first sheet is the main one the containing all the name of the projects.
the author sheets are for every project.
in the main sheet the name of the project has hyperlink to his sheet.
when running the code I got a pop msgbox that I write the new project name (look for "project_name").
the code does stuff.
but near the end there is the hyperlink code. (look for ActiveSheet.Hyperlinks.Add....)
so my problem is:
when I choose a project name like "abcd" everything works ok. But when I choose name like "ab cd". the code runs but the hyperlink doesn't work.
I realized that having a space in the project name makes the code not work.
thanks for the help.
p.s.
The notes are in Hebrew.
Sub New_project()
'--------------------------------------------------------------------------------------------------תחילת ריצת קוד
Dim Start, Finish, TotalTime As Date
Start = Timer
'--------------------------------------------------------------------------------------------------ביטול חישובים ועדכוני מסך והתראות
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
'--------------------------------------------------------------------------------------------------החזרת חישובים ועדכוני מסך והתראות
'Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
'Application.DisplayAlerts = True
'Application.AskToUpdateLinks = True
'--------------------------------------------------------------------------------------------------פתיחת חלונית והקלדת שם הפרויקט
'--------------------------------------------------------------------------------------------------אם לחצו cancel אז יציאה מהקוד
Dim project_name As String
project_name = InputBox("נא להקליד את שם הפרויקט החדש")
If Len(project_name) < 1 Then
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
MsgBox ("יציאה מהקוד")
Exit Sub
End If
'--------------------------------------------------------------------------------------------------בדיקה האם שם הגיליון לפרויקט החדש כבר קיים
Dim curSheet As Worksheet
Dim ArraySheets() As String
Dim x As Variant
Dim sheet_existing As Integer
x = 0
sheet_existing = 0
For Each curSheet In ActiveWorkbook.Worksheets
If curSheet.Name Like project_name Then
Worksheets(project_name).Activate
sheet_existing = 1
Finish = Timer
TotalTime = Format((Finish - Start) / 86400, "hh:mm:ss")
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
MsgBox ("שם הפרויקט כבר קיים" & vbNewLine & "זמן ריצת קוד: " & TotalTime)
Exit Sub
End If
Next curSheet
'iComp = StrComp(str1, str2, vbBinaryCompare)
'--------------------------------------------------------------------------------------------------הוספת גיליון חדש בסוף הקובץ
If sheet_existing = 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = project_name
End If
'--------------------------------------------------------------------------------------------------הוספת כותרות
Range("A1") = "#"
Range("B1") = "תאריך"
Range("C1") = "שלב"
Range("D1") = "איש קשר"
Range("E1") = "הערות"
Range("F1") = "מסמכים"
Range("G1") = "ימים"
Range("H1") = "צבירה"
'--------------------------------------------------------------------------------------------------רוחב עמודה
Columns("A").ColumnWidth = 9
Columns("B").ColumnWidth = 11
Columns("C").ColumnWidth = 30
Columns("D").ColumnWidth = 16
Columns("E").ColumnWidth = 17
Columns("F").ColumnWidth = 9
Columns("G").ColumnWidth = 6
Columns("H").ColumnWidth = 10
'--------------------------------------------------------------------------------------------------הוספת מסגרת לתאים
Dim rng1 As Range
Set rng1 = Range(Cells(1, 1), Cells(27, 8))
With rng1.Borders
.LineStyle = xlContinuous
.Color = vbBlack
.Weight = xlThin
End With
Range("A:H").HorizontalAlignment = xlCenter
Range("A:H").VerticalAlignment = xlCenter
Rows(1).Font.Bold = True
Columns(1).Font.Bold = True
Range("A1:H1").Interior.Color = RGB(0, 176, 240)
Range("A2") = 1
Range("B2") = Date
'Range("C2") = "רשום כאן את השלב הראשון"
Range("G2") = 0
Range("H2") = 0
Range("N1:Q1").Merge
Range("N2:Q12").Merge
Range("N1:Q1").Interior.Color = RGB(0, 176, 240)
Range("N1:Q1") = "הערות"
'--------------------------------------------------------------------------------------------------הוספת מסגרת לתאים
Dim rng2 As Range
Set rng2 = Range(Cells(1, 14), Cells(12, 17))
With rng2.Borders
.LineStyle = xlContinuous
.Color = vbBlack
.Weight = xlThin
End With
Range("N:Q").HorizontalAlignment = xlCenter
Range("N:Q").VerticalAlignment = xlCenter
'--------------------------------------------------------------------------------------------------ספירת גיליונות בקובץ
Dim SheetCountA As Integer
SheetCountA = Application.Sheets.Count
'--------------------------------------------------------------------------------------------------העתקת כפתור חזרה לגיליון החדש
Sheets(SheetCountA - 1).Select
ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
Selection.Copy
Sheets(SheetCountA).Select
ActiveSheet.Paste Destination:=Worksheets(SheetCountA).Range("K1")
Sheets(SheetCountA - 1).Select
Range("B1").Copy
Sheets(SheetCountA).Select
Range("B1").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Range("A1").Select
Sheets(SheetCountA - 1).Select
Range("A1").Select
Sheets("סיכום").Select
Dim LastRowA As Integer
LastRowA = Application.CountA(Range("B:B"))
'--------------------------------------------------------------------------------------------------הוספת מספור לפרויקט החדש
Cells(LastRowA + 1, 1) = Cells(LastRowA, 1) + 1
'--------------------------------------------------------------------------------------------------הוספת היפר-לינק
ActiveSheet.Hyperlinks.Add Anchor:=Cells(LastRowA + 1, 2), Address:="", SubAddress:= _
project_name & "!A1", TextToDisplay:=project_name
Cells(LastRowA + 1, 2).HorizontalAlignment = xlCenter
Cells(LastRowA + 1, 2).VerticalAlignment = xlCenter
Range("A1").Select
'--------------------------------------------------------------------------------------------------זמן סיום ריצת קוד וחישוב
Finish = Timer
TotalTime = Format((Finish - Start) / 86400, "hh:mm:ss")
MsgBox ("הדו''ח מוכן" & vbNewLine & "זמן ריצת קוד: " & TotalTime)
'--------------------------------------------------------------------------------------------------שאלה האם לעבור לקוד שמרענן את הקובץ
Dim answer2 As Integer
answer2 = MsgBox("?האם לרענן את הקובץ", vbYesNo + vbQuestion, "מעבר לקוד הבא")
If answer2 = vbYes Then
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Call Refresh_file
End If
'--------------------------------------------------------------------------------------------------שמירת הקובץ
ThisWorkbook.Save
'--------------------------------------------------------------------------------------------------החזרת חישובים ועדכוני מסך והתראות
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
End Sub
To make the hyperlink valid, you just need to wrap the sheet name in quotes, so:
ActiveSheet.Hyperlinks.Add Anchor:=Cells(LastRowA + 1, 2), Address:="", SubAddress:= _
project_name & "!A1", TextToDisplay:=project_name
becomes
ActiveSheet.Hyperlinks.Add Anchor:=Cells(LastRowA + 1, 2), Address:="", SubAddress:="'" & _
project_name & "'" & "!A1", TextToDisplay:=project_name

Compile error invalid Next Control Variable Reference VBA

I keep getting Compile error invalid Next Control Variable Reference Anyone can help.
I need the code to loop through Sheet1 Column A and copy and paste the value to Sheet2(R1) Then loop through Sheet1 column B and copy each value paste it to Sheet2(I7) then save the worksheet as a new PDF document
Private Sub CommandButton1_Click()
Dim i As Long
Dim n As Long
Dim m As Integer
NumRows1 = Range("A2", Range("A2").End(xlDown)).Rows.Count
NumRows2 = Range("B2", Range("B2").End(xlDown)).Rows.Count
For i = 2 To NumRows1
Range("i").Select
Sheets("Sheet1").Select
Selection.Copy
Sheets("Sheet2").Select
Range("R1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 20
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
For n = 2 To NumRows2
Range("n").Select
Sheets("Sheet1").Select
Selection.Copy
Sheets("Sheet2").Select
Range("I7").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
For m = 0 To 300
Sheets("Sheet2").Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & CStr(m) & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=False
Next i
Next n
Next m
 Application.ScreenUpdating = True
End Sub
Try this
Sub Demo()
Dim srcSht As Worksheet, destSht As Worksheet
Dim lastRow As Long
Dim cel As Range, rng As Range
Set srcSht = ThisWorkbook.Sheets("Sheet1") 'this is your source sheet
Set destSht = ThisWorkbook.Sheets("Sheet2") 'this is your destination sheet
With srcSht
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'get last row with data in Column A of srcSht
For Each cel In .Range("A2:A" & lastRow) 'loop through each cell in Column A of srcSht
cel.Copy destSht.Range("R1") 'copy cell in Column A of srcSht to Cell R1 of destSht
cel.Offset(0, 1).Copy destSht.Range("I7") 'copy cell in Column B of srcSht to Cell I7 of destSht
Set rng = Union(destSht.Range("R1"), destSht.Range("I7")) 'union cell R1 and I7
With rng.Font 'format union range
.Name = "Calibri"
.Size = 20
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
destSht.Range("I7").Font.Size = 16
'I've not tested save as pdf file part
destSht.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & (cel.Row - 1) & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=False
Next cel
End With
End Sub
Note : I've not tested saving file as pdf part.

Macro That Shows Dialog Box Upon Close If Certain Condition Occurs For Multiple Excel Files in a Folder

The following code loops through a bunch of .xlsx files in a folder and performs certain tasks such as insterting data validation in a specific cell range, conditional formatting within the same range and protecting the sheet and entire workbook to protect the integrity of the data. I would like to add one more piece of logic to the code below. I would like to add code to have a dialiog box pop up informing a user of a missed responses in the data validation range. So in simple terms, if person is required to enter a response (Y or N) in a cell for a given amount of rows misses one, a dialog box will pop up when he or she closes the Excel to let them know. I don't wan't to restrict the person from saving file. Just to let them know that a response was missed. Thank you!
Sub ProtectSheetsAndDataValidation()
'
' Access_Review_Final Macro
'
Dim MyFolder As String
Dim myFile As String
Dim wbk As Workbook
On Error Resume Next
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
myFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While myFile <> “”
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(FileName:=MyFolder & myFile)
'Replace the line below with the statements you would want your macro to perform
If Err.Number <> 0 Then
MsgBox ("Unable to open file " & myFile)
End If
On Error GoTo 0
Sheets(1).Select
Sheets(1).Name = "MAR"
Cells.Select
Range("K1").Activate
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
LastRow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
Range("A1").Select
Selection.Cut
Range("J1").Select
ActiveSheet.Paste
Range("K4:K" & LastRow).Select
Selection.Locked = False
Selection.FormulaHidden = False
Range("K4:K" & LastRow).Select
With Selection
.HorizontalAlignment = xlCenter
End With
Range("K4:K" & LastRow).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("K4:K" & LastRow).Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=LEN(TRIM(K4))>0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Pattern = xlNone
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("J3").Select
Selection.Copy
Range("K3").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("K4").Select
Range("K4:K" & LastRow).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="Y,N,n,y"
.IgnoreBlank = False
.InCellDropdown = False
.InputTitle = ""
.ErrorTitle = "Invalid Response"
.InputMessage = "Please Enter ""Y"" or ""N"". Case doesn't matter."
.ErrorMessage = "Please Enter ""Y"" or ""N"". Case doesn't matter."
.ShowInput = True
.ShowError = True
End With
Range("K11").Select
Range("K16").Select
Rows("3:3").Select
Range("H3").Activate
Selection.AutoFilter
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowSorting:= _
True, AllowFiltering:=True, Password:="adgiam"
ActiveWorkbook.Protect Structure:=True, Windows:=False, Password:="adgiam"
ActiveWindow.ScrollColumn = 9
wbk.Close SaveChanges:=True
myFile = Dir 'DIR gets the next file in the folder
Loop
Application.ScreenUpdating = True
MsgBox "Macro has completed! Woot! Woot!"
End Sub
you could use Workbook_BeforeClose event handler
what follows assumes that:
worksheet "Validation" is to be checked for missing validation
in worksheet "Validation", validation cells are in column K from row 4 down to last not empty row of column "B"
here's the code
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim cell As Range
Dim addrStrng As String
With Worksheets("Validations")
For Each cell In .Range("K4:K" & .Cells(.Rows.Count, "B").End(xlUp).Row)
With cell.Validation
.IgnoreBlank = False
If Not .Value Then addrStrng = addrStrng & cell.address(False, False) & vbCrLf
End With
Next cell
If addrStrng <> "" Then
MsgBox "There are validation data input missing in: " & vbCrLf & vbCrLf & addrStrng
Cancel = True
End If
End With
End Sub

Loop code to run macro multiple times

I have this vba macro that extracts data from a text file and puts it into a column in Excel. The files are named by days (2016mmdd). Currently, I run this macro for each day. Now I want it such that when this Macro is run, the data for all the days in the declared month (say August) will be automatically extracted into different columns (a column per each day of the month). So that I won't have to manually run it 31 times if there are 31 days in the month. Thanks for helping.
Sub Macro7()
'
' Macro7 Macro
'
' Keyboard Shortcut: Ctrl+x
'
Dim fileDate, rng, rng1, rng2, rng3, rcell As String
b = InputBox("Enter file Name mmdd", "File name")
rcell = InputBox("Enter cell reference", "Reference name")
rng = "$" & rcell & "$2"
rng1 = rcell & "2:" & rcell & "14"
rng2 = rcell & "52:" & rcell & "62"
rng3 = rcell & "2:" & rcell & "101"
Filename = "j:\files\2016" & b & "2259.txt"
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;j:\files2016" & b & "2259.txt", Destination:= _
Range(rng))
.Name = "tr" & b
.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 = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(9, 1, 9)
.TextFileFixedColumnWidths = Array(103, 4)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Range(rng1).Select
Selection.Delete Shift:=xlUp
ActiveWindow.SmallScroll Down:=45
Range(rng2).Select
Selection.Delete Shift:=xlUp
ActiveWindow.SmallScroll Down:=-60
Range(rng3).Select
End Sub
The quick approach would be to re-write Sub Macro7() to accept parameters, e.g.
Sub ImportFiles(FName As String, ColNum As Integer)
' blablabla
' work with range objects ... not with patched strings containing range addresses
Dim Rng As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range
Set Rng = Cells(2, ColNum)
Set Rng1 = Range(Cells(2, ColNum), Cells(14, ColNum))
Set Rng2 = Range(Cells(52, ColNum), Cells(62, ColNum))
Set Rng3 = Range(Cells(2, ColNum), Cells(101, ColNum))
Filename = "j:\files\2016" & FName & "2259.txt"
' and replace <Destination := Range(Rng)> by <Destination := Rng>
' blablabla
' use the range objects defined/set earlier ... save on Select/Selection
Rng1.Delete xlUp
Rng2.Delete xlUp
Rng3.Select
End Sub
and have a calling Macro e.g.
Sub DoWorklist()
ImportFiles "0901", 1
ImportFiles "0902", 2
ImportFiles "0903", 3
' blablabla
'alternative
Dim Idx As Integer
For Idx = 1 To 30
' to overcome well spotted chr() issue we convert running number Idx
' into 2 digit string with leading "0"
ImportFiles "09" & Format(Idx, "00"), Idx
Next Idx
End Sub