excel VBA 2013 Compatibility issues - vba

I have just had an upgrade from office 2010 to office 2013. The VBA scripting which I had ran perfectly fine in office 2010 with no issues, since the upgrade it now crashes when the button is clicked to run the code. I stepped through the code line by line to see what the problem was but it worked fine, didn't crash it done everything it was suppose to do.
Is this a compatibility issue? I know the scripting is correct, but it know causes excel to not respond and shut down when the button is clicked and the scripting now runs really slow where as before it was fast.
Here is the code which I am running:
Dim x As Workbook 'Saved workbook from email (MEP)
Dim y As Workbook 'Saved workbook from email (PS)
Dim sht1 As Worksheet 'Current active worksheet (Formatted)
Dim LResult As String
Dim RangeSort As Range
Dim RangeKey As Range
Dim majVarCount As Integer
Dim minVarCount As Integer
Dim onTrackCount As Integer
Dim rng As Range
Dim iVal As Integer
Dim compStartRow As Integer
Dim compEndRow As Integer
'Open Closed Project PS report
Set y = Workbooks.Open("C:\documents\Closed.xlsx") 'Path for workbook to copy from
lastRow = Cells(Rows.Count, 2).End(xlUp).Row 'Find the last row
Rows(lastRow).Delete 'Deletes un-necessary row
'Find last row again after deleting un-necessary row
lastRow = Cells(Rows.Count, 2).End(xlUp).Row
'Copy over required data
Range("B6:E" & lastRow).Select
Selection.Hyperlinks.Delete
Selection.Copy
Workbooks("Formatted").Worksheets("Formatted").Range("E22").Insert Shift:=xlDown
Range("F6:F" & lastRow).Select
Selection.Copy
Workbooks("Formatted").Worksheets("Formatted").Range("K22").Insert Shift:=xlDown '(Global/Regional)
Range("G6:G" & lastRow).Select
Selection.Copy
Workbooks("Formatted").Worksheets("Formatted").Range("M22").Insert Shift:=xlDown
Range("H6:H" & lastRow).Select
Selection.Copy
Workbooks("Formatted").Worksheets("Formatted").Range("X22").Insert Shift:=xlDown
Range("I6:K" & lastRow).Select
Selection.Copy
Workbooks("Formatted").Worksheets("Formatted").Range("AS22").Insert Shift:=xlDown
Application.DisplayAlerts = False
y.Close
'To remove characters after the first blank space in column M
lastRow = Cells(Rows.Count, "M").End(xlUp).Row
Range("M22:M" & lastRow).Replace What:=" *", Replacement:="", LookAt:=xlPart
'Change strings from "Green = OnTrack, Amber = Minor Variance, Red = Significant Variance"
With Range("AS:AU")
.Replace What:="Green", Replacement:="On Track"
.Replace What:="Amber", Replacement:="Minor Variance"
.Replace What:="Red", Replacement:="Significant Variance"
End With
'Checking the last row
lastRow = Cells(Rows.Count, 5).End(xlUp).Row
'Used to confirm that LastRow worked displays as message
'MsgBox "Last Row: " & lastRow
'Searching for blank cells and populating with'On track'
With Range("AS22:AU" & lastRow)
.Replace What:="", Replacement:="On Track"
End With
With Range("X22:X" & lastRow)
.Replace What:="", Replacement:="Complete"
End With
'Clear contents in column DP no not needed
lastRow = Cells(Rows.Count, 5).End(xlUp).Row
Range("DP22:DP" & lastRow).ClearContents
With Worksheets("Formatted")
lastRow = .Cells(Rows.Count, 5).End(xlUp).Row
For Each rng In .Range("DP22:DP" & lastRow)
rng.Formula = "=IF(COUNTIF(AS" & rng.Row & ":AU" & rng.Row & ", ""Significant Variance""), ""Significant Variance"", " & _
"IF(COUNTIF(AS" & rng.Row & ":AU" & rng.Row & ", ""Minor Variance""), ""Minor Variance"", " & _
"""On Track""))"
rng.Value = rng.Value
Next rng
End With
'Find the range of cells for Complete Project
compStartRow = Range("X:X").Find(What:="Complete", after:=Range("X21")).Row
compEndRow = Range("X:X").Find(What:="Complete", after:=Range("X21"), SearchDirection:=xlPrevious).Row
'MsgBox "First and Last Row for Complete Projects: " & compStartRow & compEndRow 'Used for checking first and last row values are correct
'Counts the values and paste in to Count Table sheet
iVal = Application.WorksheetFunction.CountIf(Range("DP" & compStartRow & ":DP" & compEndRow), "On Track")
Worksheets("Count Table").Range("E8").Value = iVal
iVal = Application.WorksheetFunction.CountIf(Range("DP" & compStartRow & ":DP" & compEndRow), "Minor Variance")
Worksheets("Count Table").Range("D8").Value = iVal
iVal = Application.WorksheetFunction.CountIf(Range("DP" & compStartRow & ":DP" & compEndRow), "Significant Variance")
Worksheets("Count Table").Range("C8").Value = iVal
'Clear contents in column DP not needed
lastRow = Cells(Rows.Count, 5).End(xlUp).Row
Range("DP22:DP" & lastRow).ClearContents
'Copy information from the Lookup table sheet into the Formatted sheet and clears the clipboard
Sheets("Lookup Table").Range("C5").Copy Sheets("Formatted").Range("L22:L" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C4").Copy Sheets("Formatted").Range("J22:J" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C6").Copy Sheets("Formatted").Range("K22:K" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C8").Copy Sheets("Formatted").Range("Q22:Q" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C10").Copy Sheets("Formatted").Range("AQ22:AQ" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C11").Copy Sheets("Formatted").Range("AR22:AR" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C13").Copy Sheets("Formatted").Range("BD22:BD" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C15").Copy Sheets("Formatted").Range("BF22:BF" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C17").Copy Sheets("Formatted").Range("BH22:BH" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C19").Copy Sheets("Formatted").Range("BJ22:BJ" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C21").Copy Sheets("Formatted").Range("BL22:BL" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C23").Copy Sheets("Formatted").Range("BN22:BN" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C24").Copy Sheets("Formatted").Range("BO22:BO" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C25").Copy Sheets("Formatted").Range("BP22:BP" & lastRow)
Application.CutCopyMode = False
'Remove cell borders
Set rng = ActiveSheet.Range("E22:BP" & lastRow)
rng.Borders.LineStyle = xlNone
'Save formatted sheet as new workbook before overlay has been applied
FPath = "C:\documents\Reports\formatted\"
FName = "Formatted with Closed" & Format(Now, "ddmmmyyyy_hhmm") & ".xls"
Set NewBook = Workbooks.add
ThisWorkbook.Sheets("Formatted").Copy Before:=NewBook.Sheets(1)
NewBook.SaveAs Filename:=FPath & "\" & FName
Application.DisplayAlerts = False
NewBook.Close

Related

Excel VBA: Split data into multiple worksheets based on row and condition

I have master list, which I want to divide into separate worksheets based on Job Role. In addition, only courses marked with an "X" should appear in the individual worksheet. See image of master list below
IMAGE
Basing off my code from this sample, but to no avail (error I had was unable to get the Match property of WorksheetFunction class): https://www.extendoffice.com/documents/excel/1174-excel-split-data-into-multiple-worksheets-based-on-column.html
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vrow, i As Integer
Dim irow As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vrow = 6
Set ws = ActiveSheet
lr = ws.Cells(vrow, ws.Columns.Count).End(xlToLeft).Column
irow = ws.Rows.Count
For i = 7 To lr
If ws.Cells(vrow, i) <> " " And Application.WorksheetFunction.Match(ws.Cells(vrow, i), ws.Rows(irow), 0) = 0 Then
ws.Cells(irow, ws.Columns.Count).End(xlUp).Offset(1) = ws.Cells(vrow, i)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Rows(irow).SpecialCells(xlCellTypeConstants))
ws.Rows(irow).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vrow, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
I think this should do what you want.
Sub Copy_To_Worksheets()
'Note: This macro use the function LastRow
Dim My_Range As Range
Dim FieldNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2 As Worksheet
Dim Lrow As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long
'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
My_Range.Parent.Select
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
End If
'This example filters on the first column in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 1
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Add a worksheet to copy the a unique list and add the CriteriaRange
Set ws2 = Worksheets.Add
With ws2
'first we copy the Unique data from the filter field to ws2
My_Range.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)
'Filter the range
My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
'Check if there are no more then 8192 areas(limit of areas)
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
.Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas for the value : " & cell.Value _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Split in worksheets"
Else
'Add a new worksheet
Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count))
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
ErrNum = ErrNum + 1
WSNew.Name = "Error_" & Format(ErrNum, "0000")
Err.Clear
End If
On Error GoTo 0
'Copy the visible data to the new worksheet
My_Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
End If
'Show all data in the range
My_Range.AutoFilter Field:=FieldNum
Next cell
'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0
End With
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
If ErrNum > 0 Then
MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
& vbNewLine & "There are characters in the name that are not allowed" _
& vbNewLine & "in a sheet name or the worksheet already exist."
End If
'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Here is the link:
https://www.rondebruin.nl/win/s3/win006_4.htm
Or, this.
Sub Copy_To_Workbooks()
'Note: This macro use the function LastRow
Dim My_Range As Range
Dim FieldNum As Long
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2 As Worksheet
Dim MyPath As String
Dim foldername As String
Dim Lrow As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long
'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
My_Range.Parent.Select
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new workbook"
Exit Sub
End If
'This example filters on the first column in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 1
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
'Set the file extension/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
If ActiveWorkbook.FileFormat = 56 Then
FileExtStr = ".xls": FileFormatNum = 56
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Delete the sheet RDBLogSheet if it exists
On Error Resume Next
Application.DisplayAlerts = False
Sheets("RDBLogSheet").Delete
Application.DisplayAlerts = True
On Error GoTo 0
' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count))
ws2.Name = "RDBLogSheet"
'Fill in the path\folder where you want the new folder with the files
'you can use also this "C:\Users\Ron\test"
MyPath = Application.DefaultFilePath
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'Create folder for the new files
foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
MkDir foldername
With ws2
'first we copy the Unique data from the filter field to ws2
My_Range.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A3"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A4:A" & Lrow)
'Filter the range
My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
'Check if there are no more then 8192 areas(limit of areas)
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
.Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas for the value : " & cell.Value _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Split in worksheets"
Else
'Add new workbook with one sheet
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Copy/paste the visible data to the new workbook
My_Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
'Save the file in the new folder and close it
On Error Resume Next
WSNew.Parent.SaveAs foldername & _
cell.Value & FileExtStr, FileFormatNum
If Err.Number > 0 Then
Err.Clear
ErrNum = ErrNum + 1
WSNew.Parent.SaveAs foldername & _
"Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum
.Cells(cell.Row, "B").Formula = "=Hyperlink(""" & foldername & _
"Error_" & Format(ErrNum, "0000") & FileExtStr & """)"
.Cells(cell.Row, "A").Interior.Color = vbRed
Else
.Cells(cell.Row, "B").Formula = _
"=Hyperlink(""" & foldername & cell.Value & FileExtStr & """)"
End If
WSNew.Parent.Close False
On Error GoTo 0
End If
'Show all the data in the range
My_Range.AutoFilter Field:=FieldNum
Next cell
.Cells(1, "A").Value = "Red cell: can't use the Unique name as file name"
.Cells(1, "B").Value = "Created Files (Click on the link to open a file)"
.Cells(3, "A").Value = "Unique Values"
.Cells(3, "B").Value = "Full Path and File name"
.Cells(3, "A").Font.Bold = True
.Cells(3, "B").Font.Bold = True
.Columns("A:B").AutoFit
End With
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
If ErrNum > 0 Then
MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
& vbNewLine & "There are characters in the name that are not allowed" _
& vbNewLine & "in a sheet name or the worksheet already exist."
End If
'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
ws2.Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
https://www.rondebruin.nl/win/s3/win006_3.htm

Excel VBA Looping in sheet and saving every looped file based on cell range

Anyone,
I'm trying to make a program in excel vba in which the macro would look/loop for the sheet name in the workbook base on the excel range. Also, after looking for the sheet name, the program would save the sheet based on the given file name on the other cell range.
My main problem here is on how I can save the loop file/sheet name based on the teritory name given in the picture provided below.
Hope you can help me with my problem.
Here's my recent work on the macro, I can save the file but it saves the file based on the sheet name I have looked up. Thanks.
sample picture here
Sub Save_Test()
Dim ws As Worksheet
Dim wb As Workbook
Dim c, b As Range
Dim rng, rng2 As Range
Dim mysheet As Worksheet
Dim LastRow, LastRow2 As Integer
Dim file_name As String
LastRow = Range("I" & rows.Count).End(xlUp).row
Set rng = Range("J5:J" & LastRow)
Set ws = Worksheets("Control")
For Each c In rng
Sheets(c.Value).Select
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Application.DisplayAlerts = False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
ActiveSheet.Name = c.Value
Application.CutCopyMode = False
ActiveWindow.DisplayGridlines = False
TemplateLocation = ThisWorkbook.Path
file_name = c.Value
ActiveWorkbook.SaveAs Filename:=TemplateLocation & "\" & "Reports" & "\" & Format(Now() - 1, "mmyy") & " " & file_name & " Hustle Board thru " & Format(Now() - 1, "mm-dd-yy"), FileFormat:=51, CreateBackup:=False
Application.DisplayAlerts = False
ActiveWindow.Close
Next
Sheets("Control").Select
End Sub
You will have to fill in the other stuff you need to do, but going off your picture and you code, this should get you the value in the teritory column
Dim r As Range
Dim rng As Range
Dim LastRow As Long
Dim ws As Worksheet
LastRow = Range("I" & Rows.Count).End(xlUp).Row
Set rng = Range("J5:J" & LastRow)
For Each r In rng
file_name = r.Offset(, -1)
ActiveWorkbook.SaveAs Filename:=TemplateLocation & "\" & "Reports" & "\" & Format(Now() - 1, "mmyy") & " " & file_name & " Hustle Board thru " & Format(Now() - 1, "mm-dd-yy"), FileFormat:=51, CreateBackup:=False
Next r
End Sub
BTW, if you did not already know, declaring varibales like this below is not good practice.
Dim rng, rng2 As Range
In this case rng is not a rng at this point. You need to do this below to explicitly declare as a Range variable.
Dim rng as Range, rng2 As Range

Add a another constant/column to this macro?

What this does now is take whats inputted Columns A:E and add whatever you list in column F, at the end of it, keeping A:E constant. This makes it much easier rather than copying and pasting but i want to add another row so that A:F is constant, switching the list to column G.
For ex, once it's outputted,
A1,B1,C1,D1,E1,F1
A1,B1,C1,D1,E1,F2
A1,B1,C1,D1,E1,F3
etc.
I just want to add another column to make it
A1,B1,C1,D1,E1,F1,G1
A1,B1,C1,D1,E1,F1,G2
A1,B1,C1,D1,E1,F1,G3
This is what I have so far.
Dim LastRowIput As String
With Sheets("Input")
LastRowInput = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
For I = 2 To LastRowInput
Dim LastRowLoc As String
With Sheets("Output")
LastRowLoc = .Cells(.Rows.Count, "F").End(xlUp).Row + 1
End With
Sheets("Input").Select
Range("F2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Output").Select
Range("F" & LastRowLoc).Select
ActiveSheet.Paste
Sheets("Input").Select
Range("A" & I & ":" & "E" & I).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Output").Select
Dim LastRow As String
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
End With
Range("A" & LastRow).Select
ActiveSheet.Paste
Dim LastRowLoc2 As String
With Sheets("Output")
LastRowLoc2 = .Cells(.Rows.Count, "F").End(xlUp).Row
End With
Application.CutCopyMode = False
Range("A" & LastRow & ":" & "E" & LastRowLoc2).Select
Selection.FillDown
Sheets("Input").Select
Next I
It seems that you want to copy the rows from A:G from Input to Output, expanding A:F in Output for every row in G.
Dim i As Long, lastRowInput As Long, nextRowOutput As Long
Dim wso As Worksheet
Set wso = Worksheets("Output")
With Sheets("Input")
lastRowInput = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 2 To lastRowInput
nextRowOutput = wso.Cells(.Rows.Count, "G").End(xlUp).Row + 1
.Range(.Cells(2, "G"), .Cells(2, "G").End(xlDown)).Copy _
Destination:=wso.Cells(nextRowOutput, "G")
.Range("A" & i & ":" & "F" & i).Copy _
Destination:=wso.Range(wso.Cells(nextRowOutput, "A"), _
wso.Cells(wso.Cells(.Rows.Count, "G").End(xlUp).Row, "F"))
Next i
End With
I've removed all methods involving the Range .Select and Range .Activate methods in favor of direct referencing.
                             Sample data from Input worksheet
                             Sample results from Output worksheet

Running VBA code in alternate sheet triggers wrong results - despite referencing?

The below code seeks to pull the value from a cell in the the 'Input' sheet, and then display it in the 'Output' sheet. It then shows the difference between the last value recorded and expresses the figure as a percentage.
When I run this code with the Output sheet active it works. However, when I run it from the output sheet it doesn't. Instead, it displays the value I wish to copy in column F in the input sheet and displays the difference and percentage difference in the wrong cells in the Output sheet.
It looks correctly referenced to me, but it obviously isn't. Thoughts on how to correct?
I appreciate that the code could be tidier - i'm very new to this.
Sub Button1_Click()
Dim LastRow As Long
Dim RecentRow As Long
With Sheets("Output")
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
RecentRow = .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0).Row
Range("F" & LastRow).Select
ActiveCell.Offset(1, 0).Formula = "=Input!B4"
ActiveCell.Offset(1, 0).Copy
ActiveCell.Offset(1, 0).PasteSpecial (xlValues)
End With
ActiveCell.Offset(0, 1).Formula = "=(F" & RecentRow & "-F" & LastRow & ")"
ActiveCell.Offset(0, 2).Formula = "=((F" & RecentRow & "/F" & LastRow & ")-1)"
End Sub
Thanks.
The below code should fix your issue - it's because your Range("F" & LastRow).Select did not have a period before Range.
Sub Button1_Click()
Dim LastRow As Long
Dim RecentRow As Long
With Sheets("Output")
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
RecentRow = .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0).Row
With .Range("F" & LastRow)
.Offset(1, 0).Formula = "=Input!B4"
.Offset(1, 0).Copy
.Offset(1, 0).PasteSpecial (xlValues)
.Offset(0, 1).Formula = "=(F" & RecentRow & "-F" & LastRow & ")"
.Offset(0, 2).Formula = "=((F" & RecentRow & "/F" & LastRow & ")-1)"
End With
End With
End Sub
Furthermore, you can gain a bit more efficiency in your code with the below:
Sub Button1_Click()
Dim LastRow As Long
With ThisWorkbook.Sheets("Output") 'Allow for code to work even if in another workbook.
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
With .Range("F" & LastRow)
.Offset(1, 0).Value2 = ThisWorkbook.Sheets("Input").Range("B4").Value2
.Offset(0, 1).Formula = "=(F" & LastRow + 1 & "-F" & LastRow & ")"
.Offset(0, 2).Formula = "=((F" & LastRow + 1 & "/F" & LastRow & ")-1)"
End With
End With
End Sub

Merge Multiple Excel Sheets Into Summary Sheet

I wonder whether someone may be able to help me please.
I'm using the code below to allow the user to copy from multiple Excel workbooks and merge the data into a Summary sheet.
Sub Merge()
Dim DestWB As Workbook, WB As Workbook, WS As Worksheet, SourceSheet As String
Set DestWB = ActiveWorkbook
SourceSheet = "Input"
startrow = 7
FileNames = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select the workbooks to merge.", MultiSelect:=True)
If IsArray(FileNames) = False Then
If FileNames = False Then
Exit Sub
End If
End If
For n = LBound(FileNames) To UBound(FileNames)
Set WB = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
For Each WS In WB.Worksheets
If WS.Name = SourceSheet Then
With WS
If .UsedRange.Cells.Count > 1 Then
dr = DestWB.Worksheets("Input").Range("C" & Rows.Count).End(xlUp).Row + 1
lastrow = .Range("C" & Rows.Count).End(xlUp).Row
For j = lastrow To startrow Step -1
If Range("E" & j) <> "Requirements Manager" And Range("E" & j) <> "R & D Lead" And Range("E" & j) <> "Technical" And Range("E" & j) <> "Analyst" Then Rows(j).Delete
Next
lastrow = .Range("C" & Rows.Count).End(xlUp).Row
If lastrow >= startrow Then
.Range("A" & startrow & ":AQ" & lastrow).Copy
DestWB.Worksheets("Input").Cells(dr, "A").PasteSpecial xlValues
End If
End If
End With
Exit For
End If
Next WS
WB.Close savechanges:=False
Next n
End Sub
The code works fine but I'm stuck with a problem related to the copying of the information, which is this line of code:
.Range("A" & startrow & ":AQ" & lastrow).Copy
I need to change this so that it takes into account two ranges. These are columns "B:AD" and "AF:AQ", but I'm not sure how to do this.
I just wondered wehether someone could possibly take a look at this please and offer some guidance on how I may go about solving this.
Many thanks and kind regards
In all the following I assume that you indeed don't want column A copied to the destination workbook and sheet.
You could use Union to copy paste it in one go (then any columns in between it will not be reflected when pasting:
If lastrow >= startrow Then
Union(.Range("B" & startrow & ":AD" & lastrow), .Range("AF" & startrow & ":AQ" & lastrow).Copy
DestWB.Worksheets("Input").Cells(dr, "B").PasteSpecial xlValues
End If
If you want it pasted with room between it as well then you could simply r3epeat the copy and paste lines:
If lastrow >= startrow Then
.Range("B" & startrow & ":AD" & lastrow).Copy
DestWB.Worksheets("Input").Cells(dr, "B").PasteSpecial xlValues
.Range("AF" & startrow & ":AQ" & lastrow).Copy
DestWB.Worksheets("Input").Cells(dr, "AF").PasteSpecial xlValues
End If