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
Related
It's been a few years since VBA class so please respond as if you were writing in an "Excel VBA for Dummies" book.
In column G, each cell in range G2:G1001 is an individual data validation drop down list of all the worksheets in my workbook. I have a macro that when you select "Questar" from the dropdown in cell "G2", it copies cells A2:F2 and pastes them to the worksheet titled "Questar" in the first empty row. That all works fine.
However, my issue is it only works in cell G2. I have data in rows 2-1001 and I need this to work for all cells G2:G1001. Here is what I have so far and works for cell "G2":
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("G2:G1001")) Is Nothing Then
Select Case Range("G2")
Case "Questar": Questar
End Select
End If
End Sub
I think that the Select Case Range("G2") needs to change but I have tried everything.
Here is my Questar macro code:
Sub Questar()
Worksheets("AFCU Auto-Add").Range(ActiveCell.Offset(0, -6), ActiveCell.Offset(0, -1)).Copy
Worksheets("Questar").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("AFCU Auto-Add").Select
Range(ActiveCell.Offset(0, -6), ActiveCell.Offset(0, -1)).Select
Application.CutCopyMode = False
Selection.ListObject.ListRows(1).Delete
Range("G2").Select
End Sub
I will eventually add more cases but I want to get one worksheet working correctly before adding more cases and macros. Any suggestions?
EDIT: updated to single procedure, assuming all sheets exist which are named in column G...
Something like:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range, rngDel As Range
On Error GoTo haveError
Set rng = Intersect(Target, Range("G2:G1001"))
If Not rng Is Nothing Then
For Each c In rng.Cells
If Len(c.Value) > 0 Then
'copy to appropiate sheet
With ThisWorkbook.Worksheets(c.Value).Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0).Resize(1, rng.Cells.Count).Value = _
c.EntireRow.Range("A1:F1").Value
End With
'build up a range of rows to delete...
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Union(c, rngDel)
End If
End If
Next c
'any rows to delete?
If Not rngDel Is Nothing Then
Application.EnableEvents = False
rngDel.EntireRow.Delete
Application.EnableEvents = True
End If
End If
Exit Sub
haveError:
'make sure to re-enable events in the case of an error
Application.EnableEvents = True
End Sub
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.
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
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