I am having trouble pasting.
I have written the code but when it gets to cell and selects it I have tried putting paste in but still does not work.
Code below, the starred bit is the issue
Sheets("Data").Select
If Range("A2") = "" Then
Range("A1").Paste
Else
Selection.End(xlDown).Select
ActiveCell. Offset(0, 1).Select
With Range("A" & Rows.Count).End(xlUp).Offset(1)
End With
ActiveSheet.Range("$D$1:$D$50000").AutoFilter Field:=6, Criteria1:="B"
lastrow = Range("D" & Rows.Count).End(xlUp).Row
Range("D:M").SpecialCells(xlCellTypeVisible).Select
Set Rng = ActiveSheet.AutoFilter.Range
Windows("Pull Back Scans.xlsm").Activate
Sheets("Data").Select
If Range("A2") = "" Then
Range("A1").Paste
Else
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
With Range("A" & Rows.Count).End(xlUp).Offset(1)
End With
**ActiveSheet.PasteSpecial**
Columns("A:J").Select
Columns("A:J").EntireColumn.AutoFit
Windows("Belfast CDC Scans.xlsb").Activate
ActiveWorkbook.Close savechanges:=False
End If
Columns("A:J").Select
Columns("A:J").EntireColumn.AutoFit
Windows("Belfast CDC Scans.xlsb").Activate
ActiveWorkbook.Close savechanges:=False
End If
Related
everyone. I am newie on this, but i need this so i am asking for your help.
I am building a macro to copy filtered data from several books to a consolitation one. The following code run fine until one filtered worksheet has no result rows, then it copy a range of empty cells, in that moment a receive an error 1004 that a can't solve. This is my code (result of several adaptation of code to my need):
Sub MergeDataFromWorkbooks()
Dim wbk As Workbook
Dim wbk1 As Workbook
Set wbk1 = ThisWorkbook
Dim Filename As String
Dim Path As String
Path = "D:\Reportes\Prueba\"
Filename = Dir(Path & "*.xlsx")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Do While Len(Filename) > 0
Set wbk = Workbooks.Open(Path & Filename)
wbk.Activate
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
With ActiveSheet
.AutoFilterMode = False
.Range("B6:BB6").AutoFilter field:=8, Criteria1:="*Nacional*"
End With
Range("B7").Select
Range(Selection, "BA7").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Windows("Merged.xlsm").Activate
Application.DisplayAlerts = False
Dim lr As Double
lr = wbk1.Sheets(1).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'Sheets("Hoja1").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Sheets("Hoja1").Select
Cells(lr + 1, 1).Select
ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True
Application.CutCopyMode = False
wbk.Close True
Filename = Dir
Loop
MsgBox "All the files are copied and pasted in Merged."
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
you have to check whether there are any filtered cells, so wrap copy/paste statements inside some If - Then as follows:
With ActiveSheet
.AutoFilterMode = False
.Range("B6:BB6").AutoFilter field:=8, Criteria1:="*Nacional*"
End With
If Application.WorksheetFunction.Subtotal(103, Intersect(ActiveSheet.UsedRange, Columns(2))) > 1 Then
Range("B7").Select
Range(Selection, "BA7").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.copy
Windows("Merged.xlsm").Activate
Application.DisplayAlerts = False
Dim lr As Double
lr = wbk1.Sheets(1).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
'Sheets("Hoja1").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Sheets("Hoja1").Select
Cells(lr + 1, 1).Select
ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True
Application.CutCopyMode = False
End If
wbk.Close True
Filename = Dir
Check for visible values in the filtered range before copying.
With ActiveSheet
.AutoFilterMode = False
with .Range("B6:BB6")
.AutoFilter field:=8, Criteria1:="*Nacional*"
with .resize(.rows.count-1, .columns.count).offset(1, 0)
if cbool(application.subtotal(103, .cells)) then
.SpecialCells(xlCellTypeVisible).copy
end if
end with
end with
End With
It's probably better to work out the destination beforehand and use the Destination parameter of the copy operation.
I am using a VBA macro to insert a column whereby it searches for a text character in column A.
My code runs correctly. However, the file appears like it is going to crash. I will be building on the macro and want it to run smoothly.
Is there a way to optimise my code
Code:
Sheets("Annual Rec").Select
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.NumberFormat = "General"
Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row).Formula = "=ISTEXT(RC[-1])"
Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
The code below does the same as yours, just without the unnecessary Select and Selection.
Option Explicit
Sub CopyColPasteVal()
Application.ScreenUpdating = False
With Sheets("Annual Rec")
.Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Columns("B:B").NumberFormat = "General"
With .Range("B2:B" & .Range("A" & .Rows.Count).End(xlUp).Row)
.Formula = "=ISTEXT(RC[-1])"
.Copy
.PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
End With
Application.ScreenUpdating = True
End Sub
Try this:
Application.ScreenUpdating = False
'your code
Application.ScreenUpdating = True
And avoid Select statements, they are quite slow.
How can i make my code go faster?
It's go real slow when the Vlookup is active and i don't know how to make it go fast.
It takes more than 2 minute and it's the same as doing manually.
Sub
Columns("I:I").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("J1").Select
ActiveCell.FormulaR1C1 = "KEY"
Range("I1").Select
ActiveCell.FormulaR1C1 = "CHECK"
Range("J2").Select
ActiveCell.FormulaR1C1 = "=RC[7]&RC[12]&RC[16]"
Range("J2").Select
Selection.AutoFill Destination:=Range("j2:j" & cells(Rows.Count, "a").End(xlUp).Row)
Sheets("CSI Plans Report").Select
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Application.Calculation = xlManual
Sheets("CSI Plan ww").Select
Range("J1:N1").Select
Selection.Copy
Sheets("CSI Plans Report").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.AutoFilter
Selection.AutoFilter
Range("A2").Select
ActiveCell.FormulaR1C1 = "=RC[7]&RC[12]&RC[16]"
Range("B2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],'CSI Plan ww'!C[8]:C[12],2,0)"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],'CSI Plan ww'!C[7]:C[11],3,0)"
Range("D2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],'CSI Plan ww'!C[6]:C[10],4,0)"
Range("E2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-4],'CSI Plan ww'!C[5]:C[9],5,0)"
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A" & cells(Rows.Count, "f").End(xlUp).Row)
Range("B2").Select
Selection.AutoFill Destination:=Range("b2:b" & cells(Rows.Count, "f").End(xlUp).Row)
Range("C2").Select
Selection.AutoFill Destination:=Range("c2:c" & cells(Rows.Count, "f").End(xlUp).Row)
Range("D2").Select
Selection.AutoFill Destination:=Range("d2:d" & cells(Rows.Count, "f").End(xlUp).Row)
Range("E2").Select
Selection.AutoFill Destination:=Range("e2:e" & cells(Rows.Count, "f").End(xlUp).Row)
Application.Calculation = xlAutomatic
Range("A:E").Select
Range("A:E").Copy
Range("A:E").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("CSI Plan ww").Select
Range("I2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[1],'CSI Plans Report'!C[-8]:C[-3],6,0)"
Range("I2").Select
Selection.AutoFill Destination:=Range("i2:i" & cells(Rows.Count, "a").End(xlUp).Row)
Columns("I:J").Copy
Columns("I:J").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
This:
Range("A:E").Select
Range("A:E").Copy
Range("A:E").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
can be written as just:
Range("A:E").Value = Range("A:E").Value
to achieve best performance in excel VBA try to not use Select.
instead of
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A" & cells(Rows.Count, "f").End(xlUp).Row)
better use this
Range("A2").AutoFill Destination:=Range("A2:A" & cells(Rows.Count, "f").End(xlUp).Row)
And best what you can do is to specify sheet too (but it has nothing to do with performance, its just good practice)
Sheets("someSheetName").Range("A2").AutoFill Destination:=Range("A2:A" & cells(Rows.Count, "f").End(xlUp).Row)
And i strongly recomend to use on begining of your sub
application.screenUpdating = false
and this on end of your sub
application.screenUpdating = true
So your excel wont show any change imediately, but at once at the end of the code. (you can read more about screenUpdating almost everywhere on web)
I think this can make you some performance boost.
If you turn off calculation you will save significant periods of time that would otherwise be devoted to calculating formulas that are only oin to be recalculated later.
If you put your formulas into all the rows at once, you do not have to have the calculation on; if you put them into a single cell and fill down you need to run a calculation cycle.
Anytime you can do multiple things at once is better than doing things repeatedly.
Everyone will tell you to read this. It is good advice.
Here's is my contribution to the rewrite process.
Option Explicit
Sub sonic()
Dim lr As Long
'uncomment the next line when you have completed debugging
'appTGGL bTGGL:=False 'see appTGGL helper sub below for details on suspending the enviroment
With Worksheets("CSI Plan ww") '<~~you should know what worksheet you are on!!
'don't insert a sinle column twice - insert 2 columns
.Columns("I:J").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'never do something twice when you do two things at once
.Range("I1:J1") = Array("CHECK", "KEY")
'write all of the formulas at once
.Range(.Cells(2, "J"), .Cells(Rows.Count, "A").End(xlUp).Offset(0, 9)). _
FormulaR1C1 = "=RC17&RC22&RC26"
End With
With Worksheets("CSI Plans Report")
'again - all at once
.Columns("A:E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'no need to select to make a copy
Worksheets("CSI Plan ww").Range("J1:N1").Copy _
Destination:=.Range("A1")
'collect the last row so it doesn't have to be repeatedly looked up
lr = .Cells(Rows.Count, "F").End(xlUp).Row
'each column's formulas all at once
.Range("A2:A" & lr).FormulaR1C1 = "=RC8&RC13&RC17"
.Range("B2:B" & lr).FormulaR1C1 = "=VLOOKUP(RC1,'CSI Plan ww'!C10:C14, 2, 0)"
.Range("C2:C" & lr).FormulaR1C1 = "=VLOOKUP(RC1,'CSI Plan ww'!C10:C14, 3, 0)"
.Range("D2:D" & lr).FormulaR1C1 = "=VLOOKUP(RC1,'CSI Plan ww'!C10:C14, 4, 0)"
.Range("E2:E" & lr).FormulaR1C1 = "=VLOOKUP(RC1,'CSI Plan ww'!C10:C14, 5, 0)"
.Range("A2:E" & lr) = .Range("A2:E" & lr).Value2 'use .Value if any of these are dates
End With
With Worksheets("CSI Plan ww")
.Range(.Cells(2, "I"), .Cells(Rows.Count, "A").End(xlUp).Offset(0, 8)). _
FormulaR1C1 = "=VLOOKUP(RC10,'CSI Plans Report'!C1:C6, 6, 0)"
'collect the last row so it doesn't have to be repeatedly looked up
lr = .Cells(Rows.Count, "J").End(xlUp).Row
'revert formulas to values
.Range("I2:J" & lr) = .Range("I2:J" & lr).Value2 'use .Value if any of these are dates
End With
appTGGL 'turn everything back on
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
With Application
.ScreenUpdating = bTGGL
.EnableEvents = bTGGL
.DisplayAlerts = bTGGL
.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
.CutCopyMode = False
.StatusBar = vbNullString
End With
Debug.Print Timer
End Sub
What I usually do, when writing macros is the following:
Public Sub MyMainMacro
Call OnStart
'Here comes the code
Call OnEnd
End Sub
Public Sub OnStart()
Application.ScreenUpdating = False
Application.Calculation = xlAutomatic
Application.EnableEvents = False
End Sub
Public Sub OnEnd()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.StatusBar = False
End Sub
I need to build a Macro that creates new workbooks based on the values in Column M (distributors). So I would have a new workbook for each distributor. I've tried modifying others on here that were attempting something similar with no success. Thanks in advance.
Here is the macro that I'm trying to get similar results from. The differences are that I need mine based off of column M instead of B. Also, my sheet's name is "taxes_20150619-145507", not Sheet1. I've tried to change these in the code but keep getting errors!
Sub details()
Dim thisWB As String
Dim newWB As String
thisWB = ActiveWorkbook.Name
On Error Resume Next
Sheets("tempsheet").Delete
On Error GoTo 0
Sheets.Add
ActiveSheet.Name = "tempsheet"
Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Then
Cells.Select
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End If
Columns("B:B").Select
Selection.Copy
Sheets("tempsheet").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
If (Cells(1, 1) = "") Then
lastrow = Cells(1, 1).End(xlDown).Row
If lastrow <> Rows.Count Then
Range("A1:A" & lastrow - 1).Select
Selection.Delete Shift:=xlUp
End If
End If
Columns("A:A").Select
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("B1"), Unique:=True
Columns("A:A").Delete
Cells.Select
Selection.Sort _
Key1:=Range("A2"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
lMaxSupp = Cells(Rows.Count, 1).End(xlUp).Row
For suppno = 2 To lMaxSupp
Windows(thisWB).Activate
supName = Sheets("tempsheet").Range("A" & suppno)
If supName <> "" Then
Workbooks.Add
ActiveWorkbook.SaveAs supName
newWB = ActiveWorkbook.Name
Windows(thisWB).Activate
Sheets("Sheet1").Select
Cells.Select
If ActiveSheet.AutoFilterMode = False Then
Selection.AutoFilter
End If
Selection.AutoFilter Field:=2, Criteria1:="=" & supName, _
Operator:=xlAnd, Criteria2:="<>"
lastrow = Cells(Rows.Count, 2).End(xlUp).Row
Rows("1:" & lastrow).Copy
Windows(newWB).Activate
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
End If
Next
Sheets("tempsheet").Delete
Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Then
Cells.Select
ActiveSheet.ShowAllData
End If
End Sub
Try this.
Sub AddNew()
Set NewBook = Workbooks.Add
With NewBook
.SaveAs fileName:="Allsales.xls" 'Replace with the column M's value
End With
End Sub
My program works by calling a number of macros as such:
Sub Start()
Call ClearAll
Call Sales_Download
Call Copy_Sales
Call Receipt_Download
Call Copy_Receipt
Call Copy1
Call Sales_Summary
Call Copy2
Call Receipt_Summary
End Sub
My program breaks at the copy2, which is essentially an exact replica of copy1 wich works fine. When copy2 is ran by itself it works perfectly, but when I attempt to run the entire program it debugs. The bolded line is where the debug happens.
Sub Copy2()
' Copies all data from Receipt Download tab for each location, and saves in a seperate folder
Dim i As Long
Dim lngLastRow As Long, lngPasteRow As Long
'Find the last row to search through
lngLastRow = Sheets("Receipt_Download").Range("J65535").End(xlUp).Row
'Initialize the Paste Row
lngPasteRow = 2
Dim rng As Range
Dim c As Range
Dim endrow
Dim strName As String
Dim ws As Worksheet
Dim j As Long
endrow = Sheets("names").Range("A65000").End(xlUp).Row
Set rng = Sheets("names").Range("A2:A" & endrow)
j = 1
FBO = strName
For Each c In rng
For i = 2 To lngLastRow
strName = c.Value
If Sheets("Receipt_Download").Range("J" & i).Value = strName Then
Sheets("Receipt_Download").Select
Range("A" & i & ":IV" & i).Copy
Sheets("Summary").Select
Range("A" & lngPasteRow & ":IV" & lngPasteRow).Select
ActiveSheet.Paste
lngPasteRow = lngPasteRow + 1
End If
Next i
j = j + 1
Sheets("Receipt_Download").Select
Rows("1:1").Select
Selection.Copy
Sheets("Summary").Select
Rows("1:1").Select
ActiveSheet.Paste
Columns("D:E").Select
Selection.NumberFormat = "m/d/yyyy"
Sheets("Summary").Select
Range("B25000").Select
ActiveCell.FormulaR1C1 = "Grand Total"
Range("B25000").Select
Selection.Font.Bold = True
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Range("G1").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]=0,""0"",RC[-1])"
Range("G1").Select
Selection.AutoFill Destination:=Range("G1:G24950")
Range("G25000").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-24950]C:R[-1]C)"
Range("G25000").Select
Selection.Copy
Range("F25000").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("G:G").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Sheets("Summary").Select
Range("F25000").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Names").Select
With Columns("B")
.Find(what:="", after:=.Cells(1, 1), LookIn:=xlValues).Activate
End With
ActiveSheet.Paste
Sheets("Summary").Select
Range("b1:b30000").Select
For Each Cell In Selection
If Cell.Value = "" Then
Cell.ClearContents
End If
Next Cell
Range("b1:b30000").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Sheets("Summary").Select
Range("D2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Names").Select
***With Columns("C")
.Find(what:="", after:=.Cells(1, 1), LookIn:=xlValues).Activate***
End With
ActiveSheet.Paste
Sheets("Summary").Select
Range("A1:Z5000").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
File = "C:\Documents and Settings\user\Desktop\New FBO\" & strName & "\" & strName & " Receipts.xls"
ActiveWorkbook.SaveAs Filename:=File, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
IngPasteRow = IngPasteRow + 1
Sheets("Summary").Select
Selection.ClearContents
Next c
End Sub
I would really appreciate any help, I am certainly no VBA master and this has been quite troublesome.
Replace this part of your code
Sheets("Summary").Select
Range("D2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Names").Select
With Columns("C")
.Find(what:="", after:=.Cells(1, 1), LookIn:=xlValues).Activate
End With
ActiveSheet.Paste
with
Dim lRow As Long
With Sheets("Names")
lRow = .Range("C" & .Rows.Count).End(xlUp).Row + 1
Sheets("Summary").Range("D2").Copy .Range("C" & lRow)
End With
Now try it.
Also few tips
Avoid .Select and .Activate They are a major cause of errors
Indent and appropriately comment your code. Your code is very difficult to read. If you don't indent/comment your code, you will realize that you will not recognize your OWN code if you visit it say after a week :)
In support of Siddharth's answer above, I have take a portion of your code (up to where your break happens) and have indented and avoided the .Select and .Activate that he mentions. Hopefully this gives you a good start on how to make your code more readable for debugging and understanding.
For Each c In rng
For i = 2 To lngLastRow
strName = c.Value
If Sheets("Receipt_Download").Range("J" & i).Value = strName Then
Sheets("Receipt_Download").Range("A" & i & ":IV" & i).Copy _
Destination:=Sheets("Summary").Range("A" & lngPasteRow & ":IV" & lngPasteRow)
lngPasteRow = lngPasteRow + 1
End If
Next i
j = j + 1
Sheets("Receipt_Download").Rows("1:1").Copy Destination:=Sheets("Summary").Rows("1:1")
With Sheets("Summary")
.Columns("D:E").NumberFormat = "m/d/yyyy"
With .Range("B25000")
.Formula = "Grand Total"
.Font.Bold = True
End With
.Columns("G:G").Insert Shift:=xlToRight
With Range("G1")
.FormulaR1C1 = "=IF(RC[-2]=0,""0"",RC[-1])"
.AutoFill Destination:=Range("G1:G24950")
End With
With ("G25000")
.FormulaR1C1 = "=SUM(R[-24950]C:R[-1]C)"
.Copy
End With
.Range("F25000").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Columns("G:G").Delete Shift:=xlToLeft
.Range("F25000").Copy Destination:=Sheets("Names").Columns("B").Find(what:="", after:=Sheets("Names").Cells(1, 1), LookIn:=xlValues)
End With