I have two sheets in my excel file - one consists of Backend Data on clients (date, quantity, rate, etc) and the other is a Summary sheet which only lists this information if the transaction is 'OPEN'. So the Backend Data sheet has a column saying whether the transaction is OPEN and if it is, it is copied to the Summary sheet. So basically the Summary sheet has a changing number of rows. This is the code I have for that (PS. it works). This code basically copy pastes the info if the transaction is OPEN and deletes the info if the transaction is no longer OPEN and then deletes any blank rows.
My main issue is that:
I want this code to be relative such that I can insert rows above and below in the Summary Sheet w/o affecting the data.
If data exists outside the Summary Sheet, I don't want it to be erased. Basically, I want the code to work only within a specific range of cells (will a Named Range help?)
Option Explicit
Sub Main()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Last_Row2 As Long, i As Integer
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Last_Row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
With ws2
For i = 1 To Last_Row2 Step 1
If .Range("F" & i).Value = "OPEN" Then
' copy pastes the info if the transaction is OPEN
ws2.Range("B" & i, "E" & i).Copy
ws1.Range("A" & i, "D" & i).PasteSpecial
ElseIf .Range("F" & i).Value = "" Then
' deletes the info if the transaction is no longer OPEN
ws1.Range("A" & i, "D" & i).ClearContents
End If
Next i
End With
Application.ScreenUpdating = True
' deletes blank rows in Summary Sheet
Dim iCounter As Long
Worksheets("Sheet1").Range("A3:D50").Select
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
For iCounter = Selection.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(Selection.Rows(iCounter)) = 0 Then
Selection.Rows(iCounter).EntireRow.Delete
End If
Next iCounter
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
ws1.Cells(1, 1).Select
End Sub
Related
I am new to VBA and I have some code which I have written and although it works I think it is bulky and not very good should a change ever need to be made to it.
The code opens a spreadsheet, runs a Function (Called "LastRow") to copy the data and another (Called "NxtRow")to paste it into the next empty row of the spreadsheet with the macro then closes the sheet that the data was copied from and moves on to the next one. Basically it is concatenating multiple sheets into one.
I am thinking that there must be a way to write the code to call the functions once and then loop through each sheet in a list. Is this possible?
My code is:
NxtRow() Function
Public Function NxtRow()
Dim BlankRow As Long
Windows("GA_BudgetTool_MASTER.xlsm").Activate
BlankRow = Range("A" & Rows.Count).End(xlUp).Row + 1
Cells(BlankRow, 1).Select
ActiveSheet.Paste
BlankRow = Range("A" & Rows.Count).End(xlUp).Row + 1
Cells(BlankRow, 1).Select
End Function
LstRow() Function
Public Function LastRow()
Dim LstRow As Long, LstCol As Long, Rng As Range, A3 As Range
LstRow = Range("A" & Rows.Count).End(xlUp).Row
LstCol = Range("O" & LstRow).Column
Set Rng = Range(Cells(LstRow, 1), Cells(LstRow, LstCol))
Set A3 = Range("A3")
Range(A3, Rng).Select
Selection.Copy
End Function
VBA Sub()
Sub ImpData()
' Deactivate Screen Updating and Display Alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Import Worksheet 1
Workbooks.Open Filename:= _
"Worksheet1_Filename.xlsx"
LastRow
NxtRow
Windows("Worksheet1.xlsx").Activate
ActiveWindow.Close
' Import Worksheet 2
Workbooks.Open Filename:= _
"Worksheet2_Filename.xlsx"
LastRow
NxtRow
Windows("Worksheet2.xlsx").Activate
ActiveWindow.Close
' Import Worksheet 3
Workbooks.Open Filename:= _
"Worksheet3_Filename.xlsx"
LastRow
NxtRow
Windows("Worksheet3.xlsx").Activate
ActiveWindow.Close
This goes on in this fashion for about 30 sheets. Is there an easier way to write this and make it easier to amend later if needed?
I would just make a little array of your filenames and then use a for loop to repeat the function calls as many times as necessary
Sub ImpData()
'Deactivate Screen Updating and Display Alerts
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Dim filenames As Variant
filenames = Array("file1", "file2")
For i = 1 To UBound(filenames) + 1
Workbooks.Open Filename:=filenames(i - 1)
LastRow
NxtRow
Windows("Worksheet" & i & ".xlsx").Activate
ActiveWindow.Close
Next i
'Reactivate Screen Updating and Display Alerts
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I have the following code which is used to copy the active line and paste it a number of times at the first blank, or available line, at the end of the data. The code prompts the user to specify the number of times to paste the copied row at the end of the data.
However, it is not working properly when the data set it is being used on is filtered on a certain field. Instead it is pasting over existing data that is within the filtered data. For example, if the row 699 is not visible because of the filter choice being applied and the data ends at row 700, so 701 would be the first blank row, it is pasting over row 699. However, it does work when the user saves in between.
Any thoughts on how to fix this issue?
Sub Transfer()
Application.ScreenUpdating = False
Dim lastrow As Long
lastrow = Sheets("ForecastedMovement").Range("A65536").End(xlUp).Row ' or + 1
On Error GoTo Finish
lngRows = CLng(InputBox("How many rows do you wish to add?"))
lngNextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & ActiveCell.Row & ":BX" & ActiveCell.Row).Copy
Range("A" & lastrow + 1 & ":BX" & lastrow + lngRows).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Finish:
If Err.Number <> 0 Then MsgBox Prompt:="Please ensure you only enter numeric values!"
Application.ScreenUpdating = True
End Sub
Sub Transfer()
Dim sht As Worksheet
Dim lastrow As Long, lngRows
Application.ScreenUpdating = False
Set sht = Sheets("ForecastedMovement")
lastrow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row + 1
'account for filtered rows at end of dataset
Do While Application.CountA(sht.Rows(lastrow)) > 0
lastrow = lastrow + 1
Loop
On Error GoTo Finish
lngRows = CLng(InputBox("How many rows do you wish to add?"))
ActiveCell.EntireRow.Range("A1:BX1").Copy
sht.Cells(lastrow, 1).Resize(lngRows).PasteSpecial Paste:=xlPasteValues
Finish:
If Err.Number <> 0 Then MsgBox Prompt:="Please ensure you only enter numeric values!"
Application.ScreenUpdating = True
End Sub
I would like to search a column, "C", and if the first letter of the word does not start with A or M, then I would like to copy the entire row and paste it in a newly created worksheet, with the same formatting. I would also like to copy the remaining rows into another new worksheet.
This is the code that I have used and have referred to several sources but I can't get the desired results. So far, I am only able to create the new worksheets, and copy into the worksheet "Rejected", however it copies everything and the criteria does not seem to work.
Sub sortfunds()
Worksheets.Add(Before:=Worksheets(Worksheets.Count)).Name = "Rejected"
Worksheets.Add(Before:=Worksheets(Worksheets.Count)).Name = "Accepted"
Dim wRejected As Worksheet
Dim wAccepted As Worksheet
Dim ws As Worksheet
Dim LastRow As Long
Dim i As Long
Dim j As Long
*'j is for 'Accepted' worksheet which I have not worked on yet*
Set ws = ActiveSheet
Set wRejected = ThisWorkbook.Sheets("Rejected")
Set wAccepted = ThisWorkbook.Sheets("Accepted")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
LastRow = Range("C" & Rows.Count).End(xlUp).Row
With ws
For i = LastRow To 1 Step -1
If Left(Range("C" & LastRow), 1) <> "A" And Left(Range("C" & LastRow), 1) <> "M" Then Rows(i).Copy wRejected.Rows(wRejected.Cells(wRejected.Rows.Count, 3).End(xlUp).Row + 1)
Next i
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
You are always checking the values in the last row instead of working through each row in turn.
Change:
If Left(Range("C" & LastRow), 1) <> "A" And Left(Range("C" & LastRow), 1) <> "M"
to:
If Left(Range("C" & i), 1) <> "A" And Left(Range("C" & i), 1) <> "M"
I have a workbook which has multiple worksheets that vary in name but the content structure of each sheet remains the same. There is only one sheet name that is always constant pie.
I am trying to apply a formula in cell N2 and then copy the formula down to the last active row in all the worksheets except the one named pie
The code I have so far is works for one loop but then i get an error "AutoFill method of Range Class failed"
I have used
Lastrow = Range("M" & Rows.Count).End(xlUp).Row
to determine the last row as column M is always complete.
Any help to complete this would be very much appreciated
Code i have is:
Sub ConcatForm()
Dim wSht As Worksheet
Lastrow = Range("M" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For Each wSht In Worksheets
If wSht.Name <> "Pie" Then
wSht.Range("N2").FormulaR1C1 = "=CONCATENATE(RC[-3],RC[-2],RC[-1])"
wSht.Range("N2").AutoFill Destination:=Range("N2:N" & Lastrow)
End If
Next wSht
Application.ScreenUpdating = True
End Sub
You don't need to use Autofill to achieve this.
Just apply your formulas directly to your range and use relative references, i.e. K2, rather than absolute references, i.e. $K$2. It will fill down and update the formula for you.
Make sure you are fully qualifying your references. For example, see where I have used ThisWorkbook and the update to how lastrow is initialized. Otherwise, Excel can get confused and throw other errors.
Your lastrow variable hasn't been dimensioned so it is an implicit Variant. You'd be better off dimensioning it explicitly as a Long.
Sub ConcatForm()
Application.ScreenUpdating = False
Dim wSht As Worksheet
Dim lastrow As Long
With ThisWorkbook.Worksheets("Sheet1") 'which worksheet to get last row?
lastrow = .Range("M" & .Rows.Count).End(xlUp).Row
End With
For Each wSht In ThisWorkbook.Worksheets
If wSht.Name <> "Pie" Then
wSht.Range("N2:N" & lastrow).Formula = "=CONCATENATE(K2,L2,M2)"
End If
Next wSht
Application.ScreenUpdating = True
End Sub
you were just one wSht reference away from the goal:
Sub ConcatForm()
Dim wSht As Worksheet
lastRow = Range("M" & Rows.count).End(xlUp).row '<--| without explicit worksheet qualification it will reference a range in the "active" sheet
Application.ScreenUpdating = False
For Each wSht In Worksheets
If wSht.Name <> "Pie" Then
wSht.Range("N2").FormulaR1C1 = "=CONCATENATE(RC[-3],RC[-2],RC[-1])"
wSht.Range("N2").AutoFill Destination:=wSht.Range("N2:N" & lastRow) '<--| this will reference a range in 'wSht' worksheet
End If
Next
Application.ScreenUpdating = True
End Sub
Use following sub...
Sub ConcatForm()
Dim wSht As Worksheet
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For Each wSht In Worksheets
With wSht
If .Name <> "Pie" Then
.Select
.Range("N2").FormulaR1C1 = "=CONCATENATE(RC[-3],RC[-2],RC[-1])"
.Range("N2").AutoFill Destination:=Range("N2:N" & Lastrow)
End If
End With
Next wSht
Application.ScreenUpdating = True
End Sub
Both of these macros are macros I found online and adapted to my use. I am using this code and it works well to separate specific data into new sheets:
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:Z" & Range("A" & Rows.Count).End(xlUp).Row)
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 = 5 'I changed this to 3 for column C
'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
What I need help with is to add a particular set of formulas to the bottom of each sheet that is created from the above macro. The following macro adds the formulas to all the sheets in the workbook. I need it to add the formulas to only the sheets that are created in the above macro. The number of sheets created change every time they are generated, depending on the source data. I was thinking it might be best to merge bottom macro into the top but I have no idea how to go about doing that.
Sub Insert_Formulas()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Activate
'Start
NxtRw = Cells(Rows.Count, "B").End(xlUp).Row + 1
With Cells(NxtRw, "B")
.Value = "Total Open Cases"
End With
With Cells(NxtRw, "C")
.EntireRow.Insert
.Value = "Total Closed Cases"
End With
'Next Row below
NxtRw = Cells(Rows.Count, "B").End(xlUp).Row + 1
With Cells(NxtRw, "B")
.Formula = "=CountIf(B2:B" & NxtRw - 1 & ", ""Open*"")"
End With
With Cells(NxtRw, "C")
.Formula = "=CountIf(B2:B" & NxtRw - 1 & ", ""Closed*"")"
End With
Next
End Sub
Any help would be greatly appreciated.
Thank you, Ck
I wouldn't combine the 2 macros, simply call the Insert_Formulas macro from the Copy_To_Worksheets macro when it is needed.
To call the macro all you need is this line:
Insert_Formulas
Edit to respond to comment:
Given you don't know how many sheets are being added I have one suggestion you may try.
High level, add text to a cell in each sheet to indicate if it is new or not. When new sheet is created cell should say "new". When not new it should say "existing". Then in the
If you want to give this a try, and let me know what doesn't work I can check back and help update the code.
In the Copy_To_Worksheets macro you'll need to add a line to set all existing sheets to "existing"
In then Copy_To_Worksheets macro add a line so that new sheets get set to "new"
In Insert_Formulas macro, still loop through all sheets, but check to see if the sheet is "new", and if so, run the code to add the formulas.
A cleaner (but slightly more difficult) option would be to define a name on each sheet (use the same name for each and limit the scope to each individual sheet) and use that instead of a cell on each sheet.
If you parametrize the function so that it takes the worksheet which needs the formulas as a parameter
Sub Insert_Formulas_Into_WorkSheet(ws As Worksheet)
ws.Activate
'Start
NxtRw = Cells(Rows.Count, "B").End(xlUp).Row + 1
With Cells(NxtRw, "B")
.Value = "Total Open Cases"
End With
With Cells(NxtRw, "C")
.EntireRow.Insert
.Value = "Total Closed Cases"
End With
'Next Row below
NxtRw = Cells(Rows.Count, "B").End(xlUp).Row + 1
With Cells(NxtRw, "B")
.Formula = "=CountIf(B2:B" & NxtRw - 1 & ", ""Open*"")"
End With
With Cells(NxtRw, "C")
.Formula = "=CountIf(B2:B" & NxtRw - 1 & ", ""Closed*"")"
End With
End Sub
Then you can add the formulas after each new worksheet is created by calling
Insert_Formulas_Into_WorkSheet WSNew