I am trying to add and copy a formula across a range of cells and then paste the values. Currently, the code I have works, BUT it takes too long to run. Do you know of a more efficient way to accomplish my goal? I am pasting the formula across 77,000 cells in ~3.69 minutes.
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Dim ws As Worksheet, Lastrow As Long
Set ws = Sheets("Sheet1")
With ws
Lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
.Range("CS1").Value = "Actual Bonus - Amount"
.Range("CS2").Formula = "=SUMIF(Table7[ID],table3[ID],Table7[Actual])"
.Range("CS2").Copy
.Range("CS3:CS" & Lastrow).PasteSpecial xlPasteFormulas
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Thank you!
You can use .FillDown to put the formulas into the cells below without having to copy/paste.
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Dim ws As Worksheet, Lastrow As Long
Set ws = Sheets("Sheet1")
With ws
Lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
.Range("CS1").Value = "Actual Bonus - Amount"
.Range("CS2").Formula = "=SUMIF(Table7[ID],table3[ID],Table7[Actual])"
.Range("CS2:CS" & Lastrow).FillDown
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Related
I have a 176 worksheets in a workbook, that all have the same format/structure, but are a difference size in row length.
I want to copy the data that is held in range A10:V(X) where X is a calculable number. This data will be pasted underneath each other, in columns B:W of the main sheet "RDBMergeSheet" and the name of the sheet that each row came from will be pasted into Column A of RDBMergeSheet so it can be seen which rows came from which sheets
X = (The lowest used row number in column J) - 3
If it makes it easier, another way to calculate X is find the row number in column A that contains the word "total" and subtract 1 from it.
The following link contains an example of such a sheet, with sanitised data.
https://imgur.com/a/emlZj
The code I've got so far, with help, is:
Sub ImportData()
Dim x As Long
Dim LR As Long
Dim wks As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set wks = Sheets("RDBMergeSheet"): If Not wks Is Nothing Then wks.Delete
Set wks = Worksheets.Add(after:=Worksheets(Sheets.Count))
wks.Name = "RDBMergeSheet"
For x = 1 To Worksheets.Count - 1
LR = Application.Max(1, Sheets(x).Cells(Rows.Count, 10).End(xlUp).Row - 3)
With wks.Cells(Rows.Count, 1)
.Offset(1, 1).Resize(LR, 22).Value = .Cells(1, 10).Resize(LR, 22).Value
.Offset(1).Resize(LR - 9).Value = Sheets(x).Name
End With
Next x
wks.Select
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set wks = Nothing
End Sub
This errors out with a 1004: Application defined or object defined error on line
.Offset(1, 1).Resize(LR, 22).Value = .Cells(1, 10).Resize(LR, 22).Value
If anyone has any ideas on either how to resolve this I would be extremely grateful.
Please give this a try and tweak it as per your requirement to make sure the correct data is copied starting from the correct row on destination sheet.
Sub ImportData()
Dim LR As Long, dLR As Long, i As Long
Dim wks As Worksheet
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
On Error Resume Next
Set wks = Sheets("RDBMergeSheet")
wks.Cells.Clear
On Error GoTo 0
If wks Is Nothing Then
Set wks = Worksheets.Add(after:=Worksheets(Sheets.Count))
wks.Name = "RDBMergeSheet"
End If
For i = 1 To Worksheets.Count - 1
If Worksheets(i).Name <> wks.Name Then
LR = Application.Max(1, Sheets(i).Cells(Rows.Count, 10).End(xlUp).Row - 3)
If LR > 9 Then
If wks.Range("B1").Value = "" Then
dLR = 1
Else
dLR = wks.UsedRange.Rows.Count + 1
End If
wks.Range("B" & dLR & ":X" & LR - 9).Value = Worksheets(i).Range("B10:X" & LR).Value
wks.Range("A" & dLR).Value = Worksheets(i).Name
End If
End If
Next i
On Error Resume Next
wks.Select
dLR = wks.UsedRange.Rows.Count
wks.Range("A1:A" & dLR).SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
wks.Range("A1:A" & dLR).Value = wks.Range("A1:A" & dLR).Value
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Set wks = Nothing
End Sub
Why code doesn't pick cell in next worksheet? My copy workbook contain 12 worksheets.
Sheet.Name = ("cat","rabbit","cow","sheep"...+8).
Each sheet have same headers. Col(B1:AK1)= year(1979,1980,...2014).
In another folder that I repeatedly open for pasting; File.Name = (1979.xlsx, 1980.xlsx,..,2014.xlsx).
In each sheet got 12 columns . Col(B1:M1)= ("cat","rabbit","cow","sheep"...+8).
Each cell in range loop nicely but worksheet doesn't seem so. When my code finish run, I check paste workbook having the same data from worksheet("cat"). I'm not competent with coding so please advise whenever my code can be improve.
Sub transferPict()
Dim wsC As Integer
Dim cell As Range
Dim Rng As Range
Dim j, i As Long
Dim x As String
Dim Folderpath
Dim file As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
wsC = ThisWorkbook.Sheets.Count
For j = 1 To wsC
i = j + 1
Set Rng = Range("B1:AK1")
For Each cell In Rng
x = cell.Value
cell.Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Folderpath = "F:\Sony Pendrive\Data Baru\Tahun\PasteTahun\"
file = Folderpath & x & ".xlsx"
Workbooks.Open (file)
ActiveWorkbook.Worksheets("sheet1").Select
ActiveSheet.Cells(2, i).Select
ActiveSheet.Paste
ActiveWorkbook.Close saveChanges:=True
Next cell
Next j
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
At no point in your code were you specifying which worksheet you want to copy from, so it will always use the "active" sheet.
Hopefully this code will correct your issue:
Sub transferPict()
Dim wsC As Integer
Dim cell As Range
Dim Rng As Range
'Dim j, i As Long ' <--- This is equivalent to Dim j As Variant, i As Long
Dim j As Long, i As Long
Dim x As String
Dim Folderpath
Dim file As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
wsC = ThisWorkbook.Sheets.Count
For j = 1 To wsC
i = j + 1
Set Rng = ThisWorkbook.Sheets(j).Range("B1:AK1")
For Each cell In Rng
x = cell.Value
ThisWorkbook.Sheets(j).Range(cell.Offset(1, 0), cell.Offset(1, 0).End(xlDown)).CopyPicture Appearance:=xlScreen, Format:=xlPicture
Folderpath = "F:\Sony Pendrive\Data Baru\Tahun\PasteTahun\"
file = Folderpath & x & ".xlsx"
Workbooks.Open file
ActiveWorkbook.Worksheets("sheet1").Cells(2, i).PasteSpecial
ActiveWorkbook.Close saveChanges:=True
Next cell
Next j
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
If the cells is equal to Disney Orlando I want to move to worksheet New or a completely new worksheet. As of now the .Rows is causing an error.
Sub finddisneys()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws1 = wb.Sheets("April")
Set ws2 = wb.Sheets("alljobs")
Set ws3 = wb.Sheets("New")
i = ws1.Cells(Rows.Count, 2).End(xlUp).Row
For i = z To 2 Step -1
If ws1.Cells(i, 2) = "Disney Orlando" Then
.Rows(i).Copy Destination:=ws3.range("A")
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Just need to do some "housekeeping" on the code:
Sub finddisneys()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws1 = wb.Sheets("April")
Set ws2 = wb.Sheets("alljobs")
Set WS3 = wb.Sheets("New")
i = ws1.Cells(ws1.Rows.Count, 2).End(xlUp).row ' Added ws1 before "Rows" for clarity
For i = z To 2 Step -1
If ws1.Cells(i, 2) = "Disney Orlando" Then
ws1.Rows(i).copy Destination:=WS3.Range("A") ' Added ws1, since you didn't have `With` anywhere.
End If
Next i ' Need this to continue the loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Edit: Ah, I see Scott and Jeeped are all over it.
I'm trying this, but it's not working:
Sub macro1()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim LR As Long
With ActiveSheet
LR = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
For r = 2 To LR
p = Application.Match(Cells(r, 3), Sheets("Input").Range("C:C"), 0)
If IsError(p) Then GoTo nextr:
Cells(r, 4).Value = .Value & ",newsletter" '***here***
nextr:
Next r
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
If I use the following on the line marked here :
Cells(r,4) = "Y"
It works, so I guess I've done my append wrong?
Just to spell out the answer and to format it nicely:
Option Explicit
Sub macro1()
Dim p As Double
Dim LR As Long
Dim r As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
LR = ActiveSheet.Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row
For r = 2 To LR
p = Application.Match(Cells(r, 3), Sheets("Input").Range("C:C"), 0)
If Not IsError(p) Then
ActiveSheet.Cells(r, 4).Value = ActiveSheet.Cells(r, 4).Value & ",newsletter" '***here***
End If
Next r
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Looking to copy rows from all sheets apart from my active sheet that meet a certain criteria in column J using VBA.
Not experienced in writing code in VBA so I have tried to frankenstein together the necessary parts from looking through other questions and answers;
below is the code I have written so far;
Sub CommandButton1_Click()
Dim lngLastRow As Long
Dim ws As Worksheet
Dim r As Long, c As Long
Dim wsRow As Long
Set Controlled = Sheets("Controlled") ' Set This to the Sheet name you want all Ok's going to
Worksheets("Controlled").Activate
r = ActiveSheet.Cells(Rows.Count, 2).End(x1up).Row
c = ActiveSheet.Cells(1, Columns.Count).End(x1ToLeft).Column
Range("J").AutoFilter
For Each ws In Worksheets
If ws.Name <> "Controlled" Then
ws.Activate
wsRow = ActiveSheet.Cells(Rows.Count, 2).End(x1up).Row + 1
Range("A" & r).AutoFilter Field:=10, Criteria1:="Y"
.Copy Controlled.Range("A3" & wsRow)
End If
Next ws
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Where Controlled is the sheet I want the data to appear in from the other sheets, and all other sheets are searched to see if their column J meets the criteria="Y"
I won't need to copy over formatting as all Sheets will have the formatting exactly the same and if possible I want the rows that are copied over to start at row 3
Try this:
Option Explicit
Sub ConsolidateY()
Dim ws As Worksheet, wsCtrl As Worksheet
Dim lrow As Long, rng As Range
Set wsCtrl = Thisworkbook.Sheets("Controlled")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each ws In Thisworkbook.Worksheets
If ws.Name = "Controlled" Then GoTo nextsheet
With ws
lrow = .Range("J" & .Rows.Count).End(xlUp).Row
.AutoFilterMode = False
Set rng = .Range("J1:J" & lrow).Find(what:="Y", after:=.Range("J" & lrow))
If rng Is Nothing Then GoTo nextsheet
.Range("J1:J" & lrow).AutoFilter Field:=1, Criteria1:="Y"
.Range("J1:J" & lrow).Offset(1,0).SpecialCells(xlCellTypeVisible).EntireRow.Copy
wsCtrl.Range("A" & wsCtrl.Rows.Count).End(xlUp).Offset(1,0).PasteSpecial xlPasteValues
.AutoFilterMode = False
Application.CutCopyMode = False
End With
nextsheet:
Next
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I think this covers everything or most of your requirement.
Not tested though so I leave it to you.
If you come across with problems, let me know.