I have a workbook that contains a database .
On that database there is a certain row of data that i would like to copy and paste to all sheets.
The copying range varies as the row data on the database changes, but the paste range for each location remains the same.
I have a code that i have done so far but it only allows to copy paste sheet by sheet and i could not define a fixed range in the code.
In this case i would like the selected data to be pasted to B1:N1 of each sheet.
Some help would be needed to paste at one goal to all sheets.
Here is my code:
Dim rng As Range, inp As Range
Set rng = Nothing
Set inp = Selection
inp.Interior.ColorIndex = 37
On Error Resume Next
Set rng = Application.InputBox("Copy to", Type:=8)
On Error GoTo 0
If TypeName(rng) <> "Range" Then
MsgBox "Cancelled", vbInformation
Exit Sub
Else
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
End If
Application.CutCopyMode = 0
do you need a Loop for all worksheets ?
Dim ws as Worksheet
For Each ws in ActiveWorkbook.Worksheets
If Not ws.Name = "*Name of the database workbook *" Then
Call ws.Range("B1:N1").PasteSpecial(xlPasteAll, xlPasteSpecialOperationNone)
End If
Next
Dim Rng As Range, _
Inp As Range, _
wS As Worksheet
Set Inp = Selection
Inp.Interior.ColorIndex = 37
On Error Resume Next
Set Rng = Application.InputBox("Copy to", Type:=8)
On Error GoTo 0
If TypeName(Rng) <> "Range" Then
MsgBox "Cancelled", vbInformation
Exit Sub
Else
Rng.Parent.Activate
Inp.Copy
For Each wS In ActiveWorkbook.Worksheets
wS.Range("B1").Paste Link:=True
Next
End If
Application.CutCopyMode = 0
Related
I am struggling to get this code right. I need to create a new worksheet for every city that is listed in column A of my worksheet called "AllCities", but only if the name of that city doesn't already exist as a worksheet. Right now my code will run but it will still add new worksheets to the end and not name them, when it should only add the last couple cities listed in the column. My current code is below.
Sub CreateSheetsFromAList()
Dim MyCell As Range
Dim MyRange As Range
With Sheets("AllCities").Range("A2")
Set MyRange = Sheets("AllCities").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
On Error Resume Next
Sheets.ADD After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
If Err.Number = 1004 Then
Debug.Print MyCell.Value & "already used as sheet name"
End If
On Error GoTo 0
Next MyCell
End With
End Sub
I find it easier to just start working on the worksheet whether it is there or not. Judicious error control will pause processing when attempted on a non-existent worksheet and allow error control to create one.
Sub CreateSheetsFromAList()
Dim myCell As Range, myRange As Range
With Sheets("AllCities")
Set myRange = Sheets("AllCities").Range("A2")
Set myRange = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
For Each myCell In myRange
On Error GoTo bm_Need_Worksheet
With Worksheets(myCell.Value)
'work on the worksheet here
End With
Next myCell
End With
Exit Sub
bm_Need_Worksheet:
With Worksheets.Add(after:=Sheets(Sheets.Count))
'trap an error on bad worksheet name
On Error GoTo 0
.Name = myCell.Value
'prep the worksheet
.Cells(1, 1).Resize(1, 9).Formula = "=""fld ""&SUBSTITUTE(ADDRESS(1,COLUMN(), 4, 1), 1, """")"
With ActiveWindow
.Zoom = 80
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
End With
Resume
End Sub
The key here is the Resume statement on the trapped error. It brings code execution back to the line that threw the error and continues processing from there.
Hi there I have this code which only copy-paste data from sheet 1 one to sheet 2.
Sub CopyPasteCumUpdate()
Dim rng As Range, inp As Range
'to remove 0 values that may be a result of a formula or direct entry.
Set rng = Nothing
Set inp = Selection
inp.Interior.ColorIndex = 37
On Error Resume Next
Set rng = Application.InputBox("Copy to", Type:=8)
On Error GoTo 0
If TypeName(rng) <> "Range" Then
MsgBox "Cancelled", vbInformation
Exit Sub
Else
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
Application.CutCopyMode = 0
End If
End Sub
Is it possible to input data and paste it to any other sheet without having to hard code?
From your comment that is easy. Just change this part:
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
Application.CutCopyMode = 0
With this:
Edit: This is to paste the link in the range the user selected.
Application.Goto rng
inp.Copy
rng.Parent.Paste Link:=True
Application.CutCopyMode = 0
I am having an issue creating a macro that will autofill a VBA function named "FindMyOrderNumber". Every time I run a macro to Autofill "FindMyOrderNumber" only the first cell in the column is populated.
This function will look up an order number in column A (A1) and return the name of the worksheet it can be found B (B1).
Option Explicit
Function FindMyOrderNumber(strOrder As String) As String
Dim ws As Worksheet
Dim rng As Range
For Each ws In Worksheets
If ws.CodeName <> "Sheet3" Then
Set rng = Nothing
On Error Resume Next
Set rng = ws.Cells.Find(What:=strOrder, LookAt:=xlWhole)
On Error GoTo 0
If Not rng Is Nothing Then
FindMyOrderNumber = ws.Name
Exit For
End If
End If
Next
Set rng = Nothing
Set ws = Nothing
End Function
I created this macro to enter my VBA function "=findmyordernumber(a1)" in cell B1 then to Autofill column B.
Sub AutofillVBAFunction()
Range("B1").Select
ActiveCell.FormulaR1C1 = "=FindMyOrderNumber(RC[-1])"
Selection.Autofill Destination:=Range("B1:B68")
Range("B1:B68").Select
End Sub
After I run this macro only B1 is populated.
Sorry if this has been discussed I am new and I tried How to fill-up cells within a Excel worksheet from a VBA function? and other questions and I could not apply it to my issue.
Please help
Add application.volatile to the function, that way it will calculate as the sheet changes.
Function FindMyOrderNumber(strOrder As String) As String
Dim ws As Worksheet
Dim rng As Range
Application.Volatile
For Each ws In Worksheets
If ws.CodeName <> "Sheet3" Then
Set rng = Nothing
On Error Resume Next
Set rng = ws.Cells.Find(What:=strOrder, LookAt:=xlWhole)
On Error GoTo 0
If Not rng Is Nothing Then
FindMyOrderNumber = ws.Name
Exit For
End If
End If
Next
Set rng = Nothing
Set ws = Nothing
End Function
It also wouldn't hurt to calculate the sheet when You add the formula to the range.
Sub Button1_Click()
Dim Rws As Long, Rng As Range
Rws = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range(Cells(1, 2), Cells(Rws, 2))
Rng = "=FindMyOrderNumber(RC[-1])"
End Sub
I have a Do Until loop in VBA.
My problem is that there is likely to be an error most days when running the macro as not all the sheets will have info on them.
When that happens I just want to start the loop again. I am assuming its not the "On Error Resume Next" I was thinking of counting the rows on the autofilter and then if it was 1 (ie only titles) starting the loop again. Just not sure how to do that.
Dim rngDates As Range 'range where date is pasted on.
'Dim strDate As String
Dim intNoOfRows As Integer
Dim rng As Range
Sub Dates()
Application.ScreenUpdating = False
Set rngWorksheetNames = Worksheets("info sheet").Range("a1")
dbleDate = Worksheets("front sheet").Range("f13")
Worksheets("info sheet").Activate
Range("a1").Activate
Do Until ActiveCell = ""
strSheet = ActiveCell
Set wsFiltering = Worksheets(strSheet)
intLastRow = wsFiltering.Cells(Rows.Count, "b").End(xlUp).Row
Set rngFilter = wsFiltering.Range("a1:a" & intLastRow)
With rngFilter
.AutoFilter Field:=1, Criteria1:="="
On Error Resume Next
Set rngDates = .Resize(.Rows.Count - 1, 1).Offset(1, 0).SpecialCells(xlCellTypeVisible)
End With
With rngDates
.Value = dbleDate
.NumberFormat = "dd/mm/yyyy"
If wsFiltering.FilterMode Then
wsFiltering.ShowAllData
End If
ActiveCell.Offset(1, 0).Select
End With
Application.ScreenUpdating = True
Worksheets("front sheet").Select
MsgBox ("Dates updated")
Loop
You could check existance of data after filtering by using SUBTOTAL formula.
If Application.WorkSheetFunction.Subtotal(103,ActiveSheet.Columns(1)) > 1 Then
'There is data
Else
'There is no data (just header row)
End If
You can read about SUBTOTAL here
Rather than using the Do Until loop, consider using a For Each loop on the Worksheets Collection.
ie.
Sub ForEachWorksheetExample()
Dim sht As Worksheet
'go to error handler if there is an error
On Error GoTo err
'loop through all the worksheets in this workbook
For Each sht In ThisWorkbook.Worksheets
'excute code if the sheet is not the summary page
'and if there is some data in the worksheet (CountA)
'(this may have to be adjusted if you have header rows)
If sht.Name <> "front sheet" And _
Application.WorksheetFunction.CountA(sht.Cells) > 0 Then
'do some stuff in here. Refer to sht as the current worksheet
End If
Next sht
Exit Sub
err:
MsgBox err.Description
End Sub
Also. I would recommend removing the On Error Resume Next statement. It is much better to deal detect and deal with errors rather than ignore them. It could cause strange results.
I am trying to combine specific sheets to one sheet from workbook. Challenge here is sheets from array might not be available all the time. so the macro should ignore those and move to next sheet to copy data. I have written code but macro throes error when sheet does not exist.
Sub test()
Dim MyArr, j As Long
Dim ws As Worksheet
Dim sary, i As Long
Worksheets.Add Before:=Worksheets("Equity")
ActiveSheet.Name = "Consolidated"
MyArr = Array("Sample Sheet_Equity", "Sample Sheet_Funds", "Sample Sheet_Warrants", "Eq", "Fu", "Wa")
For j = 0 To UBound(MyArr)
Set ws = Worksheets(MyArr(j))
If Not ws Is Nothing Then
ws.Select
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Consolidated").Select
Range("A2").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
You can do it like this:
For j = 0 To UBound(MyArr)
On Error Resume Next
Set ws = Worksheets(MyArr(j))
If Err.Number = 0 Then
On Error GoTo 0
If Not ws Is Nothing Then
'Your copying code goes here
End If
Else
Err.Clear
End If
Next
UPDATE: Thanks to Doug Glancy's comment here is more streamlined version
For j = 0 To UBound(MyArr)
Set ws = Nothing
On Error Resume Next
Set ws = Worksheets(MyArr(j))
On Error GoTo 0
If Not ws Is Nothing Then
'Your copying code goes here
End If
Next