I am trying to take a non uniform range of data on one sheet and link it up(cells will have "=Sheet1!A1", instead of hard coded values) to another worksheet within the same workbook.
I cant use just .UsedRange because I get a lot of empty cells in my selection which I don't want to link to another worksheet
Here is my code so far, but I get an error saying you can't use .copy with this kind of selection. Could someone please suggest a way around this. Thank you.
Sub test()
Application.ScreenUpdating = False
ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).Copy
With Sheets("Sheet2")
.Activate
.Range("A1").Select
ActiveSheet.Paste Link:=True
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
You can iterate over the SpecialCells ranges cell by cell, and write the links based on the source cell address, like this
Sub test()
Dim cl As Range
Dim sh As Worksheet
Dim ShName As String
Dim OldCalc As XlCalculation
Application.ScreenUpdating = False
OldCalc = Application.Calculation
Application.Calculation = xlCalculationManual
Set sh = Worksheets("Sheet2")
sh.Cells.Clear '<-- Optional
ShName = "='" & ActiveSheet.Name & "'!"
For Each cl In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
sh.Range(cl.Address).Formula = ShName & cl.Address
Next
Application.ScreenUpdating = True
Application.Calculation = OldCalc
End Sub
While looping over a range is not ideal (due to speed) it may be adequate in this case.
This Sub will error if the active sheet is empty: you may want to add an error handler for this case
Related
I am trying to create a macro which filters an export from our database, copying the filtered results to different sheets and then copying data from those new sheets across to another workbook for further processing. I have been using code from SO which has worked, but now I am trying to combine the two elements (filtering to new sheets, copy to workbooks) I am encountering some problems which as a newbie I haven't been able to solve!
Everytime I run the macro, I get a 'Subscript out of range' error on this line:
Set NAVImperial = NAVExport.Sheets("ROMAN IMPERIAL")
Even though there is definitely a worksheet with this name. Is this something to do with the use of ThisWorkbook?
Thanks in advance!
Sub Sortcodingv2()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String
'specify sheet name in which the data is stored
sht = "236"
'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "C").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:O" & last)
Sheets(sht).Range("C1:C" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=3, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x
' Turn off filter
Sheets(sht).AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
Dim NAVExport As Workbook
Set NAVExport = ThisWorkbook
' Roman Imperial
Dim NAVImperial As Worksheet
Dim LIVEImperial As Workbook
Dim LIVEImperialSheet As Worksheet
Dim UniqueIDs As Range
Dim Descriptions As Range
Dim LastRow As Long
Application.ScreenUpdating = False
Set NAVImperial = NAVExport.Sheets("ROMAN IMPERIAL")
Set LIVEImperial = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Roman Imperial.xlsm")
Set LIVEImperialSheet = LIVEImperial.Sheets("LIVE Data")
With NAVImperial
LastRow = NAVImperial.Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDs = NAVImperial.Range("B2:B" & LastRow)
Set Descriptions = NAVImperial.Range("F2:F" & LastRow)
UniqueIDs.Copy
LIVEImperialSheet.Range("A2").PasteSpecial xlPasteValues
Descriptions.Copy
LIVEImperialSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEImperialSheet.Range("C2:O" & LastRow).FillDown
LIVEImperial.Close True
Application.ScreenUpdating = True
The issue is likely that the names don't exactly match, which is why I prefer to avoid Sheets("Name") whenever I can.
If NAVExport is ThisWorkbook then all of its sheets are able to be referenced using their project names, avoiding the use of Sheets("Name"). If you open the Project Explorer (Ctrl+R). You should see a list of worksheets under Microsoft Excel Objects. The default names are Sheet1, Sheet2, Sheet3, etc. Find the one with the name in brackets as ROMAN IMPERIAL and that is the sheet you want to reference.
Then, when writing your code, you can directly write Sheet1.Cells(... or Sheet1.Range(... and you don't need to write Sheets("ROMAN IMPERIAL") anymore.
I am using the macro below by clicking a button each time I want to run it. This works ok but is quite time consuming.
In the Summary sheet (range H2:H21) of the workbook I have a list of ID numbers which I have been manually pasting into E3 before running the macro.
Instead of doing this I would like to amend the macro so it loops through all the IDs when I click the button.
The workbook is quite big and takes a while to calculate each time a new ID is pasted in so this needs to be factored in.
Can anyone show me have to do these things?
Sub CreateNewSheet()
Application.ScreenUpdating = False
Application.Calculation = xlManual
With Workbooks("Batsmen.xlsx").Worksheets.Add()
.Name = ThisWorkbook.Worksheets("Summary").Range("E3").Value
End With
With ThisWorkbook.Worksheets("Summary").Range("A22:J63").Copy
Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteFormats
Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
Workbooks("Batsmen.xlsx").Sheets(1).Range("A:J").Font.Size = 10
End With
With ThisWorkbook.Worksheets("Summary").Range("A22:J27").Copy
With Workbooks("Batsmen.xlsx").Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Font.Size = 10
End With
End With
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
This can be optimized, but should get you started.
Check the code's comments and adjust it to fit your needs.
You can put the cursos inside the Process procedure, press F8 key and see what the code does.
EDIT: Added summarySheet.Range("E3").value = cell.value to the loop
Option Explicit
Public Sub Process()
Dim targetWorkbook As Workbook
Dim summarySheet As Worksheet
Dim sourceRange As Range
Dim cell As Range
' Customize this settings
Set targetWorkbook = Workbooks("Batsmen.xlsx")
Set summarySheet = ThisWorkbook.Worksheets("Summary")
Set sourceRange = summarySheet.Range("H2:H21")
Application.ScreenUpdating = False
Application.Calculation = xlManual
' Loop through each cell in source range
For Each cell In sourceRange.Cells
' Validate that cell has a value
If cell.Value <> vbNullString Then
' Fill E3 with cell value from range in column H
summarySheet.Range("E3").value = cell.value
' Execute procedure to create new sheet
CreateNewSheet targetWorkbook, cell.Value, summarySheet
End If
Next cell
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
Private Sub CreateNewSheet(ByVal targetWorkbook As Workbook, ByVal newSheetName As String, ByVal summarySheet As Worksheet)
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets.Add
targetSheet.Name = newSheetName
summarySheet.Range("A22:J63").Copy
With targetSheet
.Range("A1").PasteSpecial Paste:=xlPasteValues
.Range("A1").PasteSpecial Paste:=xlPasteFormats
.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
.Range("A:J").Font.Size = 10
End With
summarySheet.Range("A22:J27").Copy
With targetSheet.Range("A" & Rows.Count).End(xlUp).Offset(2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Font.Size = 10
End With
End Sub
Let me know if it works
The code below should answer your question because it does create the sheets you want.
Sub CreateNewSheet()
Dim Wb As Workbook
Dim WbBat As Workbook
Dim WsSum As Worksheet
Dim NamesRange As Range
Dim i As Integer
Dim TabName As String
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With
Set Wb = ThisWorkbook
Set WbBat = Workbooks("Batsmen.xlsx")
Set WsSum = Wb.Worksheets("Summary")
Set NamesRange = WsSum.Range("H2:H21")
For i = 1 To NamesRange.Cells.Count
TabName = Trim(NamesRange.Cells(i).Value)
If Len(TabName) Then ' skip if name is blank
With WbBat.Worksheets.Add()
.Name = TabName
WsSum.Range("A22:J63").Copy Destination:=.Cells(1, "A")
WsSum.Range("A22:J27").Copy Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(2)
.Range("A:J").Columns.AutoFit
.Range("A1:J" & .Cells(.Rows.Count, "A").End(xlUp).Row).Font.Size = 10
End With
End If
Next i
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With
End Sub
Regrettably, it doesn't provide you usable code because it pastes the same data to all sheets. I presume that you have a plan how to vary the data. Unfortunately, I failed to understand such a plan from your question. However, I suspect that you will be able to modify the code to make it useful.
I need to copy a sheet and rename based on cell value.
How do I create a non-dynamic copy? I need it to be more of a screenshot so all values stay the same. The idea being I can make many still copies and edit the main sheet.
The code I have makes a dynamic copy that changes when the main does.
How would I edit this code so it is gives still image copies?
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Set wh = Worksheets(ActiveSheet.Name)
ActiveSheet.Copy After:=Worksheets(Sheets.Count)
If wh.Range("W13").Value <> "" Then
ActiveSheet.Name = wh.Range("W13").Value
End If
wh.Activate
End Sub
Two people have suggested copy and pasting special values. This adds an operation of moving the data to your clipboard, which is an external buffer outside of Excel. This has the side effect of clearing the users clipboard. If they had copied something it would now be lost.
This is faster and doesn't destroy the clipboard:
Private Sub CommandButton3_Click()
Dim oldSheet As Worksheet
Set oldSheet = ActiveSheet
oldSheet.Copy After:=Worksheets(Sheets.Count)
Dim newSheet As Worksheet
Set newSheet = ActiveSheet
If oldSheet.Range("W13").Value <> "" Then
newSheet.Name = oldSheet.Range("W13").Value
End If
With newSheet.UsedRange
.Value = .Value
End With
End Sub
Addition of these lines will help:
With ActiveSheet
.UsedRange.Copy
.UsedRange.PasteSpecial xlPasteValues
End With
You can make use of the Range.Pastespecial property of Range Class
Full Code:
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Set ws = Worksheets(ActiveSheet.Name)
ws.Copy After:=Worksheets(Sheets.Count)
With ActiveSheet
.UsedRange.Copy
.UsedRange.PasteSpecial xlPasteValues
End With
If ws.Range("W13").Value <> "" Then
ActiveSheet.Name = ws.Range("W13").Value
End If
ws.Activate
End Sub
All you are missing is to copy data and paste them as values
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Set wh = Worksheets(ActiveSheet.Name)
ActiveSheet.Copy After:=Worksheets(Sheets.Count)
If wh.Range("W13").Value <> "" Then
ActiveSheet.Name = wh.Range("W13").Value
End If
With ActiveSheet.Cells
.Copy
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("A1").Select
End With
wh.Activate
End Sub
I am working on a VBA project, that requires update of a specific table via power query as part of the code.
The code power query refresh needs to finish, before the query continues, but, i have not managed to find a solution to do that yet.
Option Explicit
Option Base 1
Public Sub LoadProductsForecast()
I have inserted a couple steps to optimise performance
'Deactivate global application parameters to optimise code performance
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
'Dimensions used in code for sheets etc.
Dim lastrow As Integer
Dim NoRowsInitial As Integer
''''''''''''''''''''''
''Get product data, and copy index match formula to look up the forecast
' find number of rows to use for clearing
NoRowsInitial = WorksheetFunction.CountA(Worksheets("Monthly Forecast").Range("D4:D15000"))
'Selecting Worksheet w. product master data
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = Sheets("Products")
wb.Activate
ws.Select
The next line is where I wish to refresh the power query, and the refresh part works as it should.
However, it countinues to run the next VBA code. I have searched for different answers online, and some refer to "DoEvents", however, it does not seem to make a difference.
ActiveWorkbook.Connections("Query - tblAdjustments").Refresh
DoEvents
Below, is the remaining code that should run after the PowerQuery has refreshed the table:
'Calculating number of rows to copy
lastrow = WorksheetFunction.CountA(Worksheets("Products").Range("B4:B15000"))
'Copying rows
Worksheets("Products").Range(Cells(4, 2), Cells(lastrow + 3, 10)).Copy
'Selecring forecast sheet
Set ws = Sheets("Monthly Forecast")
ws.Select
'Disabling alerts, so pop up for pasting data does not show (activated again later)
Application.DisplayAlerts = False
'Pasting product master data
Worksheets("Monthly Forecast").Range(Cells(8, 4), Cells(lastrow, 12)).PasteSpecial
'Creating a string that contains range to paste formula in to
Dim RangeString As String
RangeString = "N8:W" & lastrow + 7
'Copying formula to paste
Range("AJ2:AJ3").Select
Selection.Copy
'Pasting formula that looks up baseline FC (both seasonal and SES)
Range(RangeString).Select
ActiveSheet.Paste
Calculate
With Range(RangeString)
.Value = .Value
End With
'Activating alerts again
Application.DisplayAlerts = True
''''''''''''''''''''''
''Code to clean the rows that are not used
'Remove unescessary rows
Dim NPIProducts As Integer
NPIProducts = [tblNewProd].Rows.Count
'tbl.Range.Rows.Count
Dim RowsToDelete As String
RowsToDelete = lastrow + NPIProducts * 2 & ":" & NoRowsInitial
If Left(RowsToDelete, 1) = "-" Then
'do nothing (negative)
Else
[tblMonthly].Rows(RowsToDelete).Delete
End If
'''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''
''''End of main code
'Activate global application parameters again
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
'Messages end user that the calculation is done
MsgBox "Load of products and forecast finished"
End Sub
If your connection is OLEDB or ODBC you can set the background refresh temporarily to false - forcing the refresh to happen before code can continue on. Instead of calling
.Connections("Query - tblAdjustments").Refresh
do something like this:
Dim bRfresh As Boolean
With ThisWorkbook.Connections("Query - tblAdjustments").OLEDBConnection
bRfresh = .BackgroundQuery
.BackgroundQuery = False
.Refresh
.BackgroundQuery = bRfresh
End With
this example assumes you have an OLEDB connection. If you had ODBC, just replace OLEDBConnection with ODBCConnection
If you haven't already, disable background refresh for the query (plus any queries that precede that query in the evaluation chain).
You'll want to make sure that the background refresh option is not ticked. I accessed this window by right-clicking the query and then clicking Properties. I think in some other Excel versions, you might instead need to go to Data > Connections, find the query in the list and then edit its properties there.
This is untested but in theory it should work.
Split your code in two parts.
The first part ends with the refresh.
sub some_sub()
'Deactivate global application parameters to optimise code performance
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
'Dimensions used in code for sheets etc.
Dim lastrow As Integer
Dim NoRowsInitial As Integer
''''''''''''''''''''''
''Get product data, and copy index match formula to look up the forecast
' find number of rows to use for clearing
NoRowsInitial = WorksheetFunction.CountA(Worksheets("Monthly Forecast").Range("D4:D15000"))
'Selecting Worksheet w. product master data
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = Sheets("Products")
wb.Activate
ws.Select
ActiveWorkbook.Connections("Query - tblAdjustments").Refresh
end sub
Then in order to wait for it to finnish we let the sub run to end.
Then we let Excel fire the Worksheet_Change.
On the sheet:
Private Sub Worksheet_Change(ByVal Target As Range)
'Calculating number of rows to copy
lastrow = WorksheetFunction.CountA(Worksheets("Products").Range("B4:B15000"))
'Copying rows
Worksheets("Products").Range(Cells(4, 2), Cells(lastrow + 3, 10)).Copy
'Selecring forecast sheet
Set ws = Sheets("Monthly Forecast")
ws.Select
'Disabling alerts, so pop up for pasting data does not show (activated again later)
Application.DisplayAlerts = False
'Pasting product master data
Worksheets("Monthly Forecast").Range(Cells(8, 4), Cells(lastrow, 12)).PasteSpecial
'Creating a string that contains range to paste formula in to
Dim RangeString As String
RangeString = "N8:W" & lastrow + 7
'Copying formula to paste
Range("AJ2:AJ3").Select
Selection.Copy
'Pasting formula that looks up baseline FC (both seasonal and SES)
Range(RangeString).Select
ActiveSheet.Paste
Calculate
With Range(RangeString)
.Value = .Value
End With
'Activating alerts again
Application.DisplayAlerts = True
''''''''''''''''''''''
''Code to clean the rows that are not used
'Remove unescessary rows
Dim NPIProducts As Integer
NPIProducts = [tblNewProd].Rows.Count
'tbl.Range.Rows.Count
Dim RowsToDelete As String
RowsToDelete = lastrow + NPIProducts * 2 & ":" & NoRowsInitial
If Left(RowsToDelete, 1) = "-" Then
'do nothing (negative)
Else
[tblMonthly].Rows(RowsToDelete).Delete
End If
'''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''
''''End of main code
'Activate global application parameters again
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
'Messages end user that the calculation is done
MsgBox "Load of products and forecast finished"
End Sub
You can use Target to not make it run if you don't want to. I assume there is at least one cell that you know will change. Set the target there.
Please can someone help me out, I seem to be going around in circles with my problem?
I have a workbook with 4 worksheets Comparison, Office1, Office2 and Office3. On the Comparison sheet the other sheet names are listed in column A. In column B on this sheet I have a button.
What I want to do is double click the button (I have sorted the code for this) and this will then take you to cell D5 on the corresponding sheet.
At the moment I have the following code but it doesn't seem to activate the Office sheet it uses the comparison sheet.
Could anyone please let me know what I am missing?
Thanks
Sub OfficeSht()
Dim rCrit3 As Range
Dim wb As Workbook
Dim ws As Worksheet
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rCrit3 = ActiveCell.Offset(RowOffset:=0, ColumnOffset:=-2)
Debug.Print rCrit3
Set ws = rCrit3.Worksheet
ws.Activate
ActiveSheet.Range("D5").Select
Application.EnableEvents = True
End Sub
Application.Goto seems appropriate and reduces the steps to achieve your goal.
Sub OfficeSht()
Dim ws As string
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
ws = ActiveCell.Offset(RowOffset:=0, ColumnOffset:=-2).value2
Debug.Print "'" & ws & "'!D5"
Application.Goto Reference:="'" & ws & "'!R5C4" '<~~ D5 in xlR1C1
With Application
.EnableEvents = true
.ScreenUpdating = true
End With
End Sub
You may want make this a Worksheet_BeforeDoubleClick event.
You don't say what kind of button you have so I've give a couple of examples.
One piece of code that is common in all examples is WorkSheetExists which checks if the sheet name corresponds to a worksheet.
Public Function WorkSheetExists(SheetName As String) As Boolean
Dim wrkSht As Worksheet
On Error Resume Next
Set wrkSht = Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
Next are three ways to call the OfficeSht procedure.
If your buttons are ActiveX button and are in column B you can use:
Private Sub CommandButton1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
OfficeSht Me.Shapes("CommandButton1").TopLeftCell
End Sub
This code returns a reference to Top Left Cell that your button sits in - assuming your sheet name is one cell to the left of this.
The second way is if you're using a Form button.
Public Sub Button_Click()
OfficeSht Me.Shapes(Application.Caller).TopLeftCell
End Sub
Again, it returns a reference to the Top Left Cell that the button is placed in. When you add the button just assign it to the Button_Click procedure.
The third way assumes your button is actually a cell formatted to look like a button, or if you just want to double-click the sheet name in column A and do away with having a button in column B:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
OfficeSht Target
End Sub
Finally, your code to select cell D5 (Row 5, Column 4 - R5C4).
If you're clicking, or referenced cell is in, column B:
Public Sub OfficeSht(ByVal Target As Range)
Dim rLastCell As Range
Dim rDataRange As Range
Set rLastCell = Cells(Rows.Count, 1).End(xlUp)
Set rDataRange = Range("A1", rLastCell)
If Not Intersect(Target, rDataRange.Offset(, 1)) Is Nothing Then
If WorkSheetExists(Target.Offset(, -1).Value) Then
Application.Goto "'" & Target.Offset(, -1).Value & "'!R5C4"
End If
End If
End Sub
If you're clicking, or referenced cell is in, column A:
Public Sub OfficeSht(ByVal Target As Range)
Dim rLastCell As Range
Dim rDataRange As Range
Set rLastCell = Cells(Rows.Count, 1).End(xlUp)
Set rDataRange = Range("A1", rLastCell)
If Not Intersect(Target, rDataRange) Is Nothing Then
If WorkSheetExists(Target.Value) Then
Application.Goto "'" & Target.Value & "'!R5C4"
End If
End If
End Sub
Might've waffled on a bit there.... :)