I want to create a new sheet(Slave) with the name as entered in the cells A5:A50 in (master) sheet and copy the contents of the (template)sheet in the newly created slave sheet. I have got one program as below which closely matched with my requirement but 1) it doesnt take new values which i edit and create a new slave in the range provided i.e it is not dynamic and 2) i want to run the macro everytime i enter the value in the specified range.
Help would be highly appreciated
Sub CreateAndNameWorksheets()
Dim c As Range
Application.ScreenUpdating = False
For Each c In Sheets("Master").Range("A5:A50")
Sheets("Template").Copy After:=Sheets(Sheets.Count)
With c
ActiveSheet.Name = .Value
.Parent.Hyperlinks.Add Anchor:=c, Address:="", SubAddress:= _
"'" & .Text & "'!A1", TextToDisplay:=.Text
End With
Next c
Application.ScreenUpdating = True
End Sub
Put this code in the "Master" Sheet, every time you change a cell in the Range("A5:A50") it will run the desired code
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If (Target.Parent.Name = Range("A1:A50").Parent.Name) Then
Dim ints As Range
Set ints = Application.Intersect(Target, Range("A5:A50"))
If (Not (ints Is Nothing)) Then
'insert code here
End If
End If
End Sub
Related
Update
I was able to get the code to run, but I still think i'm doing something wrong. It's not copying and pasting the right value, just pasting the original value over and over. New code below.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("X2")
Dim rb As Worksheet
Set rb = ThisWorkbook.Worksheets("RB_Cur")
Dim dp As Worksheet
Set dp = ThisWorkbook.Worksheets("Dispatch Plan")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
dp.Range("V4:V16").ClearContents
With rb.Range("E1:AA1000" & rb.Range("E" & Rows.Count).End(xlUp).Row)
.AutoFilter Field:=1, Criteria1:=dp.Range("X2").Value
.AutoFilter Field:=7, Criteria1:=dp.Range("W1").Value
If .SpecialCells(xlCellTypeVisible).Count > 0 Then
rb.Range("AA1").Offset(1).Resize(10, 1).Copy
dp.Range("V4").PasteSpecial xlPasteValues
End If
End With
End If
End Sub
Original Post
I am trying to create a table where someone can input a route number into a cell and it will populate with the stops on that route. However, i'm running into some trouble getting the stop list to populate when the cell value is changed.
Picture example: When the highlighted cell (X2) is changed, I have a code that searches it in a different sheet and copies over the stops into the Stop column. The code to lookup and copy works, but it doesn't change when the number is changed.
RouteLookup code (this works)
Sub RouteLookup()
Dim rb As Worksheet
Set rb = ThisWorkbook.Worksheets("RB_Cur")
Dim dp As Worksheet
Set dp = ThisWorkbook.Worksheets("Dispatch Plan")
With rb.Range("E1:AA1000" & rb.Range("E" & Rows.Count).End(xlUp).Row)
.AutoFilter Field:=1, Criteria1:=dp.Range("X2").Value, Criteria1:="EARLY BIRD"
If .SpecialCells(xlVisible).Count > 0 Then
rb.Range("AA1").Offset(1).Resize(10, 1).Copy Destination:=dp.Range("V4")
End If
.AutoFilter Field:=1
End With
End Sub
Worksheet SelectionChange code - Whenever I try to test it, it pops up a box asking me to select the macro. I don't understand why because the code calls the RouteLookup already.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Target.Worksheet.Range("X2")) Is Nothing Then
Application.EnableEvents = False
Call RouteLookup
Application.EnableEvents = True
End If
End Sub
First of all I am super new to VBA and coding in general, however, I am building an excel workbook to automatically transfer a row in a table based off a single cell in a row. when this happens I need it to copy only the values in the cells as I have several formulas. when the copy paste operation is done I need to delete the row and re-order everything to the top while not deleting the formulas of the row. below is what I have got so far which mostly works for what I need. the only issues are it copies the entire row so I cant have a merged group of cells to the right of the row and it deletes the formulas from the cells.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 8 Then
If Target = "COMPLETED" Then
Set Tbl = Sheets("PMI ARCHIVE").ListObjects("Table3")
Tbl.ListRows.Add
nxtTblRow = Tbl.ListColumns(9).Range.Rows.Count
Target.EntireRow.Copy _
Destination:=Tbl.Range(nxtTblRow, 1)
Application.EnableEvents = False
Target.Row.ClearContents
Application.EnableEvents = True
Range("A1", Range("A1").End(xlDown)).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
End If
End If
End Sub
Try the next code, please. It assumes that you need to copy all existing values of the Target row and then clear contents of the cells not having a formula:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim arrCopy As Variant, lastColT As Long
If Target.Column = 8 Then
If Target = "COMPLETED" Then
Set tbl = Sheets("PMI ARCHIVE").ListObjects("Table3")
tbl.ListRows.aDD
nxtTblRow = tbl.ListColumns(9).Range.Rows.Count
lastColT = Cells(Target.row, Columns.Count).End(xlToLeft).Column
arrCopy = Range(Target.row, lastColT).Value
tbl.Range(nxtTblRow, 1).Resize(, UBound(arrCopy, 2)).Value = arrCopy
Application.EnableEvents = False
Range(Target.row, lastColT).SpecialCells(xlCellTypeConstants).ClearContents
Application.EnableEvents = True
'If in column A:A, an empty cell will exist (because of the above code), the range will be set up to that empty cell.
'The next way, goes to the last cell:
Range("A1", Range("A" & Rows.Count).End(xlUp)).Sort Key1:=Range("A1"), _
Order1:=xlAscending, Header:=xlYes
End If
End If
End Sub
I am not sure you need to sort only A:A column, but I kept the code as it was, from this point of view...
For concreteness, say, a user should enter a value from 1 to 99 in A1 cell of sheet1. Then sheet2 gets recalculated.
How can I generate, ex ante, a collection of all different sheet2 that may arise (with values, don't want the formulas to show)?
If you put (say) 99 in Sheet1 "A1" then Sheet2 will be saved as Sheet2_99.xlsx on desktop (change the path as suitable) with the procedure below in VBA Sheet1 object
Private Sub Worksheet_Change(ByVal Target As Range)
Application.DisplayAlerts = True
If Not Intersect(Range("A1"), Target) Is Nothing Then
Sheets("Sheet2").Copy
ActiveWorkbook.SaveAs Filename:="C:\Users\naresh\Desktop\Sheet2_" & Target.Value & ".xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
With ActiveSheet.UsedRange
.Value = .Value
End With
ActiveWorkbook.Close True
End If
End Sub
I am trying to use VBA to realize the following goal:
I have two sheets: "revenue" and "sales tax", and they record the revenue and sales tax of 100 stores from May 1st to May 28th. Now I am trying to create a sheet for each store recording its revenue and sales tax from May 1st to May 28th.
Sub test1()
Sheets("Sheet1").Select
Sheets("Sheet1").Copy Before:=Sheets(17)
Sheets("revenue").Select
Range("D154:D168").Select
Selection.Copy
Sheets("Sheet1 (2)").Select
Range("C5").Select
ActiveSheet.Paste
Sheets("sales tax").Select
Range("D138:D152").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1 (2)").Select
Range("F5").Select
ActiveSheet.Paste
Sheets("Sheet1 (2)").Select
Sheets("Sheet1 (2)").Name = " reportF "
End Sub
Using this code I am only able to establish a file for 1 store each time. What loop syntax should I use to loop through all stores?
It looks like your data has the store name in column D? This code runs down all cells in column D and copies them into separate sheets depending on the contents
Sub ExampleCode
Dim r as range 'declare a pointer variable
Dim ws as worksheet 'declare a worksheet variable
set r = Range("d1") 'point to fist cell
Do 'Start a loop
If SheetNotExist(r.text) then 'if no sheet of that name
set ws = worksheets.add(after:=worksheets.count) 'add one
ws.name = r.text 'and name it as text in r
End if
r.copy worksheets(r.text).cells(rows.count,4).end(xlup).offset(1,0) 'copy to next blank cell
set r = r.offset(1,0) 'shift pointer down one cell
Loop until r.text = "" 'keep going until r is empty
End Sub
Function SheetNotExist(s as string) as boolean 'check if sheet exists
On error goto nope 'jump on error
Dim ws as worksheet
set ws = worksheets(s) 'this will error if sheet doesn't exist
'so if we get here the sheet does exist
SheetNotExist = False 'so return false
Exit Function 'and go back
nope: 'we only get here if sheet doesn't exist
SheetNotExist = True 'so return that
End Function
Written on my phone - don't have excel so there may be typos - code may not compile therefore,
I have the below code that copies cells from one excel sheet and pastes special values into a text file.
now from the sheet I'm copying, I have a lot of cells which contain #N/A.
can anyone suggest how to exclude these cells?
thanks
Private Sub CommandButton3_Click()
Dim i As Long
Dim wb As Workbook
Dim NewWB As Workbook
Dim saveFile As String
Dim WorkRng As Range
On Error Resume Next
i = Sheets(1).Range("W158:W" & Range("W158").End(xlDown).Row).Rows.Count
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = ActiveWorkbook
Set NewWB = Application.Workbooks.Add
Thispath = wb.path
wb.Sheets(2).Range("W158:W" & i + 5).Copy
NewWB.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
NewWB.SaveAs filename:=Thispath & "\textfile.txt", FileFormat:=xlText,
CreateBackup:=False
NewWB.Close
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
The only way i can think of is to do a basic for loop to go through all the cells individually and check for their value
For Each cell In activehseet.Range("W158:W" & i + 5)
With cell
If .Value = "#N\A" Then
Exit Sub
Else
.Copy
'code to paste here
End With
Next cell
This unfortunately would take quite a while to run and would only get longer the larger the size of the database. I would suggest losing any rows/columns that aren't in use to speed this up.
However it is probably the easiest method to fix your problem
It could be possible by using an array but as I am not an expert with array manipulation i couldn't be sure. I'm sure someone a lot smarter than me could help you through that
Hope this helps get you started. Great question!
You can try to wrap your formulas in IFERROR, just select all cells which you want to wrap and run the following macro:
Sub WrapFormulasWIthIFERROR()
Dim Cell As Range
For Each Cell In Selection
If Cell.HasFormula Then
If Left(Cell.Formula, 9) <> "=IFERROR(" Then
Cell.Formula = "=IFERROR(" & Mid(Cell.Formula, 2) & ","""")"
End If
End If
Next
End Sub
If the cell value is N/A, the result will be an empty cell. Just be aware to not select the whole sheet, because it will run forever.