Basically i'm linking the cells of workbook1 with workbook2, what is the code to do that for the whole spreadsheet?
my fault not clearly explained, as you can see below i'm assigning the value of the cells in workbook1 from workbook2
Sub Macro2()
Windows("workbook2.xlsx").Activate
Windows("workbook1.xlsx").Activate
ActiveCell.FormulaR1C1 = _
"='[workbook2.xlsx]workbook1'!R18C1"
Range("A19").Select
ActiveCell.FormulaR1C1 = _
"='[workbook2.xlsx]workbook1'!R19C1"
Range("A20").Select
.........
End Sub
i was wondering whats the fastest way to do that for the range A9 to A120, E9 to E120, F9 to F120.....
This code will link all cells in all worksheets:
Sub LinkSheets()
Dim ws As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For Each ws In Worksheets
ws.UsedRange.FormulaR1C1 = "='[workbook2.xlsx]" & ws.Name & "'!RC"
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
If you only want to link certain cells from one workhsheet, try this code:
Sub LinkRange()
Workbooks("workbook1.xlsx").Worksheets("Sheet1"). _
Range("A9:A120,E9:E120,F9:F120").FormulaR1C1= _
"='[workbook2.xlsx]Sheet1'!RC"
End Sub
Sub CopyPasteEntries()
Dim i, g, h As Integer
Sheets("Sheet1").Select
Range("A1").EntireRow.Copy
Sheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteAll
i = 2
Sheets("Sheet1").Select
Do Until IsEmpty(Cells(i, 1))
i = i + 1
Loop
g = i - 1
h = 2
For i = 2 To g
Sheets("Sheet1").Select
If Cells(i, 1).Value <> "Created" Then
Cells(i, 1).EntireRow.Copy
Sheets("Sheet2").Select
Cells(h, 1).Select
ActiveCell.PasteSpecial xlPasteAll
h = h + 1
End If
Next
Application.CutCopyMode = False
End Sub
Related
Good morning,
currently I have this code to delete rows without due date (Column J) and amount paid=0 (Column H).
Sub delete_rows()
Range("A1").End(xlDown).Select
Sheets("AA").Select
Range("J2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-5]=0,"""",RC[-5])"
Range("J2").Select
Selection.AutoFill Destination:=Range("J2:J500"), Type:=xlFillDefault
Range("J2").End(xlDown).Select
Range("K2").Select
Application.ScreenUpdating = False
With Sheet2
For line = .Cells(.Rows.Count, "J").End(xlUp).Row To 2 Step -1
If .Cells(line, "J") = "" Then
.Rows(line).Delete
End If
Next linha
End With
Application.ScreenUpdating = True
ActiveCell.FormulaR1C1 = "=IF(RC[-4]="""","""",RC[-4])"
Range("K2").Select
Selection.AutoFill Destination:=Range("K2:K500"), Type:=xlFillDefault
Range("K2").End(xlDown).Select
Range("J1").Select
Application.ScreenUpdating = False
With Sheet2
For line = .Cells(.Rows.Count, "K").End(xlUp).Row To 2 Step -1
If .Cells(line, "K") = "" Then
.Rows(line).Delete
End If
Next line
End With
Application.ScreenUpdating = True
End sub()
I created a code with a defined number of lines...however it takes a long time for the code to run, because sometimes the number of lines is small and it always runs the 500 lines. What's the way to set the code so that it looks for the last filled row in column A, and then eliminate the rows where column H has values =0 and in column J no values?
Please check: find last cell. Also have a look at: avoid select.
Afterwards, I think you should be able to understand the following code, which should get you the required result:
Sub test()
Application.ScreenUpdating = False
'declare your variables
Dim ws As Worksheet
Dim Rng1 As Range, Rng2 As Range
Dim i As Long, lastRow As Long
Set ws = Sheets("AA")
With ws
'get last row in
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'set ranges for loop
Set Rng1 = Range(.Cells(2, "H"), .Cells(lastRow, "H"))
Set Rng2 = Range(.Cells(2, "J"), .Cells(lastRow, "J"))
'reverse loop
For i = Rng1.Rows.Count To 1 Step -1
'check conditions for cell in "H" and "J"
If Rng1.Cells(i) = 0 And Rng2.Cells(i) = "" Then
'defined ranges start at row 2, hence +1
ws.Rows(i + 1).Delete
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I delete rows based on the date in a column.
The dataset is around 85,000 rows and the macro can take from 30s to 5m+ with constant freezing.
I'm not sure if this is due to poorly written code or the size of the dataset.
Sub DeleteCurrentPeriod()
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets("Transaction list by date")
ws.Activate
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Insert column, autofill formula for range
Sheets("Transaction list by date").Select
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
ActiveCell.FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Selection.AutoFill Destination:=Range("AR2:AR100000"), Type:=xlFillDefault
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$100000").AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$100000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
You can give this a try (use F8 key to run it step by step)
Some suggestions:
Name your procedure and variables to something meaningful
Indent your code (you may use Rubberduckvba.com)
Split the logic in steps
Read about avoiding select and activate here
Code:
Public Sub DeleteCurrentPeriod()
On Error GoTo CleanFail
' Turn off stuff
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim transactionSheet As Worksheet
Set transactionSheet = ThisWorkbook.Worksheets("Transaction list by date")
' Turn off autofilter and show all data
transactionSheet.AutoFilterMode = False
' Find last row
Dim lastRow As Long
lastRow = transactionSheet.Cells(transactionSheet.Rows.Count, "AQ").End(xlUp).Row
' Define range to be filtered
Dim targetRange As Range
Set targetRange = transactionSheet.Range("A1:BE" & lastRow)
' Insert column
transactionSheet.Columns("AR:AR").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Add formula & calculate
transactionSheet.Range("AR2:AR" & lastRow).FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Application.Calculate
'Filter on new column for cells matching criteria
transactionSheet.Range("A1:BE" & lastRow).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
transactionSheet.Range("A2:BE" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
'Delete added column and remove filter
transactionSheet.Columns("AR:AR").Delete Shift:=xlToLeft
' Remove filter
transactionSheet.AutoFilterMode = False
'Select A1
Range("A1").Select
CleanExit:
' Turn on stuff again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
CleanFail:
MsgBox "An error occurred:" & Err.Description
GoTo CleanExit
End Sub
Let me know if it works
I've just made a couple of changes to how you work out the last row and how you do the calculation, it looks like you were comparing to a constant on the Control sheet. I wonder though why are you adding a column in and then deleting it, could you not just perform the calcs in column +1 after your data? Then you wouldn't have to create and delete the column.
'Insert column, autofill formula for range
Dim x as Long, y, lastrow
Sheets("Transaction list by date").Select
'Find the last row used
With Sheets("Transaction list by date")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
' Get the constant and perform the comparison, add "Y" to TRUE cells
x= Worksheets("Control").Cells(20,7).value
For y = 1 to lastrow
If Worksheets("Transaction list by date").Cells(y,44)>x then _
Worksheets("Transaction list by date").Cells(y,44).value = "Y"
Next y
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$" & lastrow ).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$" & lastrow).SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
Sub RemoveDups()
Const COMPARE_COL As Long = 1
Dim a, aNew(), nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim v As String, tmp
a = Worksheets("Sheet1").UsedRange
nr = UBound(a, 1)
nc = UBound(a, 2)
ReDim aNew(1 To nr, 1 To nc)
rNew = 0
v = Date
For r = 1 To nr
tmp = a(r, COMPARE_COL)
If tmp <> v Then
rNew = rNew + 1
For c = 1 To nc
aNew(rNew, c) = a(r, c)
Next c
v = tmp
End If
Next r
Worksheets("Sheet1").UsedRange = aNew
End Sub
This is an answer written by Tim Williams I just set the range to used range and set v to Date, so if you copy and paste this it will search based on the current date you run the macro looking through column 1 (A) If you want to use a different date you'll have to redefine v, you can make that equal to the cell on your control sheet. Took 1 second to "delete" 85000 rows.
I am trying to get the code to loop through the range. For example, it should be taking the value in cell M53, using it, then running through the code, and doing the same thing with the value in cell M54. The first iteration works, but then it just seems to continuously keep running in cell M53.
I am struggling to work this one out.
Sub TestMacro1()
Dim n As Integer
Dim Strike As Range
Set Strike = Range("M53:M54")
n = 1
Application.ScreenUpdating = False
For Each cell In Strike
cell.Select
Selection.Copy
Range("E19").PasteSpecial xlPasteValues
If Checker = True Then
Range("E26").Select
Selection.Copy
Range("N53").Offset(n).PasteSpecial xlPasteValues
n = n + 1
End If
Next cell
Application.ScreenUpdating = True
End Sub
The Checker Function is defined as:
Function Checker() As Boolean
Dim tmp
Dim c As Object
tmp = False
ActiveSheet.Calculate
ActiveSheet.Calculate
With ActiveSheet.UsedRange
Set c = .Find("request", LookIn:=xlValues)
If Not c Is Nothing Then
Application.OnTime Now + TimeValue("00:00:06"), "TestMacro1"
tmp = False
Else
tmp = True
End If
End With
Checker = tmp
End Function
Please try this.
Sub TestMacro2()
Sub TestMacro2()
Dim cell As Range
Dim Strike As Range
Set Strike = Range("M53:M54")
Application.ScreenUpdating = False
For Each cell In Strike
cell.Copy
Range("E19").PasteSpecial xlPasteValues 'fixed range
If Checker = True Then
ActiveSheet.Calculate
Range("E26").Copy
cell.Offset(0, 1).PasteSpecial xlPasteValues
End If
Next cell
Application.ScreenUpdating = True
End Sub
I'm using the code to add a column, bucket the value on left (via a vlookup) and then auto fill the whole column. The problem I'm having is every time I use the macro, the code is taking slightly longer and longer. Would appreciate any help :)
Here is the code:
Sub insert_col()
'
' insert_col Macro
'
' Keyboard Shortcut: Ctrl+w
'
Dim x As Variant
Dim a As Long
Dim b As Long
Dim y As Variant
Dim t As Single
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
t = Timer
ActiveSheet.Columns(ActiveCell.Column).EntireColumn.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
x = ActiveCell.Column
Cells(22, x).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],R13C1:R193C2,1)"
Cells(22, x).Select
a = ActiveCell.Column
x = ActiveCell.Row
y = ActiveCell.End(xlDown).Row
Selection.AutoFill Destination:=Range(Cells(x, a), Cells(36600, a)), Type:=xlFillDefault
ActiveCell.Offset(0, 2).Select
MsgBox Timer - t
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Thanks!
To be clearer on the comment above, your code adds additional formulae each time it is run which increases the calculation time.
You can greater simply the code along the lines below:
Sub insert_col()
' Keyboard Shortcut: Ctrl+w
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
t = Timer
ActiveCell.EntireColumn.Insert
Range(Cells(22, ActiveCell.Column), Cells(36600, ActiveCell.Column)).FormulaR1C1 = "=VLOOKUP(RC[-1],R13C1:R193C2,1)"
ActiveCell.Offset(0, 2).Select
MsgBox Timer - t
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I seek your help to copy the cell values in (column D) of the first worksheet to a specified cell location in 16 existing worksheets
i want value in
D2 in in sheet1 to sheet2 (G5)
D3 in in sheet1 to sheet3 (G5)
D4 in in sheet1 to sheet4 (G5)
and so on until the D16 is copied to G5 of sheet16
i am a newbie, i looked into several answers and tried to work out on my own but.... nothing happened
Sub latitude()
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
Do Until IsEmpty(ActiveCell)
Sheets("Calculations").Select
Range("d2").Copy
ActiveCell.Offset(1, 0).Select
'at this point i want it to copy "D3" on next loop
ActiveSheet.Range("G5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Loop
ActiveSheet.Next.Select
' and because the "Sheets("Calculations").Select" above takes it to the first sheet the whole script is a waste till now
Next I
End Sub
Alistairs attempt is good, i would however not use shtname = "Sheet" & i, instead try the following solution and think about bulletprooving it a bit (existance of worksheets) ;)
Sub Copy_to_G5()
Dim i As Integer
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
i = 2
Do Until i = 17
With ThisWorkbook
.Worksheets(1).Cells(i, 4).Copy
.Worksheets(i).Range("G5").PasteSpecial
End With
i = i + 1
Loop
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
Give this a try.
Option Explicit
Sub Copy_to_G5()
Dim sht1 As Worksheet, ws As Worksheet
Dim i As Integer
Dim shtname As String
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set sht1 = Sheets("Sheet1")
i = 2
Do Until i = 17
shtname = "Sheet" & i
sht1.Cells(i, 4).Copy
Sheets(shtname).Range("G5").PasteSpecial
i = i + 1
Loop
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub