I have created a macro to create worksheets from a list,this works fine but i have a problem, if i only have one item in the list i get an error, here is the macro:
Sub CreateSheetsFromAList()
Application.ScreenUpdating = False
Sheets("Master").Select
Sheets("Stock Removal").Visible = True
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Master").Range("A14")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets("Stock Removal").Copy after:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
Sheets("Stock Removal").Select
ActiveWindow.SelectedSheets.Visible = False
Application.ScreenUpdating = True
End Sub
You should rather use xlUp than xlDown, it is safer!
You selected the whole column previously (from row 14, until the end of the sheet!)
This will run smoothly! ;)
Sub CreateSheetsFromAList()
Application.ScreenUpdating = False
Dim wsM As Worksheet, wsSR As Worksheet
Dim MyCell As Range, MyRange As Range, LastRow As Double
Set wsM = ThisWorkbook.Sheets("Master")
Set wsSR = ThisWorkbook.Sheets("Stock Removal")
wsM.Select
wsSR.Visible = True
Set MyRange = wsM.Range("A14")
LastRow = wsM.Range("A" & wsM.Rows.Count).End(xlUp).Row
If LastRow > 14 Then
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
wsSR.Copy after:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
Else
wsSR.Copy after:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyRange.Value ' renames the new worksheet
End If
wsSR.Select
ActiveWindow.SelectedSheets.Visible = False
Application.ScreenUpdating = True
End Sub
The problem is in case if only Cell A14 has data, and the entire column A (below cell A14) is blank, in that case MyRange.End(xlDown) will result in "A1048576". So you need to find the last row in Column A, and then check if it's 14 >> If it is then your MyRange should consist of 1 cell, and that's Cell A14.
Try the code below to replace the way you Set MyRange :
With Sheets("Master")
If .Cells(.Rows.Count, "A").End(xlUp).Row = 14 Then ' if only cell A14 has data in entire Column A
Set MyRange = Sheets("Master").Range("A14")
Else
Set MyRange = Sheets("Master").Range("A14", Range("A14").End(xlDown))
End If
End With
Try with changing:
Set MyRange = Sheets("Master").Range("A14")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
To:
With Sheets("Master")
Set MyRange = .Range(Range("A14"), .Range("A" & .Range("A" & .Rows.Count).End(xlUp).row))
End With
Related
I have macro for copy one sample sheet. Numbers of sheets copies are based by different sheet values. I need insert different formulas for every copy to specific range, where row number of formula is elevated by +1. Is it possible to do this?
Example what I need:
- Sheet1 "=DATA_SELECTED!$N$2"
- Sheet2 "=DATA_SELECTED!$N$3"
- Sheet3 "=DATA_SELECTED!$N$4"
This is what I have right now without +1 in formulas.
Sub CopySheetsFromAList()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("DATA").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Set ws = Sheets("Sheet1")
For Each MyCell In MyRange
ws.Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = MyCell.Value
Sheets(Sheets.Count).Range("C3").Formula = "=DATA_SELECTED!$M$2"
Sheets(Sheets.Count).Range("C4").Formula = "=DATA_SELECTED!$N$2"
Sheets(Sheets.Count).Range("C6").Formula = "=DATA_SELECTED!$K$2"
Sheets(Sheets.Count).Range("C7").Formula = "=DATA_SELECTED!$Y$2"
Next MyCell
End Sub
maybe something like this
Option Explicit
Sub CopySheetsFromAList()
Dim MyCell As Range, MyRange As Range
Dim ws As Worksheet
Dim iRow As Long
Set MyRange = Sheets("DATA").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Set ws = Sheets("Sheet1")
For Each MyCell In MyRange
ws.Copy after:=Sheets(Sheets.Count)
iRow = iRow + 1
With Sheets(Sheets.Count)
.Name = MyCell.Value
.Range("C3").Formula = "=DATA_SELECTED!$M$" & (1 + iRow)
.Range("C4").Formula = "=DATA_SELECTED!$N$" & (1 + iRow)
.Range("C6").Formula = "=DATA_SELECTED!$K$" & (1 + iRow)
.Range("C7").Formula = "=DATA_SELECTED!$Y$" & (1 + iRow)
End With
Next MyCell
End Sub
I want to create worksheets from a list in excel using VBA, I have the below code which works fine. But it doesn't remove duplicates from the list, and if I use remove duplicates, it throws an error. :). I don't want the original column altered.
Set MyRange = Sheets("YES").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown)).RemoveDuplicates
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) ' creates a new worksheet
Sheets(Sheets.Count).Name = UCase(MyCell.Value) ' renames the new worksheet
ActiveSheet.Range("A1").Select ' selects current worksheet
Cells(1, 1).Font.Bold = True ' changes fornt to bold
ActiveCell.Value = ("Column Name") ' enters values into cell
ActiveSheet.Range("A2").Select
ActiveCell.Value = UCase(MyCell.Value) ' enters column name in cell
Next MyCell
thanks
How about this code. It will leave the original column in tact and remove the dupes in a holding range. It's also qualified more cleanly.
Dim wsYes as Worksheet
Set wsYes = Worksheets("YES")
With wsYes
Dim myRange as Range
Set myRange = .Range("A2",.Range("A2").End(xlDown))
myRange.Copy .Cells(1,.Columns.Count) 'copy to far right column
.Cells(1,.Columns.Count).Resize(myRange.Rows.Count,1).RemoveDuplicates 1, xlNo
Set myRange = .Range(.Cells(1,.Columns.Count),.Cells(1,.Columns.Count).End(XlDown))
For Each MyCell In myRange
Dim sName as String
sName = UCase(MyCell.Value)
Dim wsNew as Worksheet
Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count)) ' creates a new worksheet
With wsNew
.Name = sName
.Range("A1").Value = "Column Name"
.Range("A1").Font.Bold = True
.Range("A2").Value = sName
End With
Next MyCell
myRange.Clear
End with
Easy way (but not the best I think if you have many data):
Set MyRange = Sheets("YES").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Dim index1 As Integer
Dim index2 As Integer
index1 = 0
For Each Cell1 In MyRange
index1 = index1 + 1
index2 = 0
For Each Cell2 In MyRange
If index2 >= index1
Then Exit For
If MyCell.Value = Cell2.Value
Then Goto NextCell1
Next Cell2
Sheets.Add After:=Sheets(Sheets.Count) ' creates a new worksheet
Sheets(Sheets.Count).Name = UCase(MyCell.Value) ' renames the new worksheet
ActiveSheet.Range("A1").Select ' selects current worksheet
Cells(1, 1).Font.Bold = True ' changes fornt to bold
ActiveCell.Value = ("Column Name") ' enters values into cell
ActiveSheet.Range("A2").Select
ActiveCell.Value = UCase(MyCell.Value) ' enters column name in cell
NextCell1:
Next Cell1
I would like to create a new worksheet in my workbook; name based on the information in the C column (starting at C4) of the "Summary" Worksheet. I have the following VBA so far but when it gets to a blank cell it stops. I need it to ignore blank cells and continue. Any help?
Sub CreateSheetsFromAListTEST()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Summary").Range("C4")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add after:=Sheets(Sheets.Count) 'creates a new workbook
Sheets(Sheets.Count).Name = MyCell.Value 'renames the new workbook
Next MyCell
End Sub
replace
Set MyRange = Sheets("Summary").Range("C4")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add after:=Sheets(Sheets.Count) 'creates a new workbook
Sheets(Sheets.Count).Name = MyCell.Value 'renames the new workbook
Next MyCell
by
set MyRange=range(sheets("Summary").[c4],sheets("Summary").cells(rows.count,"C").end(xlup))
For Each MyCell In MyRange
if len(mycell.text)>0 then
Sheets.Add after:=Sheets(Sheets.Count) 'creates a new workbook
Sheets(Sheets.Count).Name = MyCell.Value 'renames the new workbook
end if
Next MyCell
I'm looking to improve my code to dynamically set ranges where data exist instead of hard coding the values. The starting value of the range will never change, but the ending value will if more month columns are added. What is the best way to approach this. Would be easier to make the range user defined?
Here's what I have:
The code will split data by unique group name starting at C5 into separate worksheets.
Public Sub Splitdatatosheets()
' Splitdatatosheets Macro
Dim Rng As Range
Dim Rng1 As Range
Dim vrb As Boolean
Dim sht As Worksheet
'Find unique value for splitting
Set Rng = Sheets("Sheet1").Range("C5")
'Find starting row to copy (Re-code to dynamically set)
Set Rng1 = Sheets("Sheet1").Range("A5:M5")
vrb = False
Do While Rng <> ""
For Each sht In Worksheets
If sht.Name = Left(Rng.Value, 31) Then
sht.Select
Range("A2").Select
Do While Selection <> ""
ActiveCell.Offset(1, 0).Activate
Loop
Rng1.Copy ActiveCell
ActiveCell.Offset(1, 0).Activate
Set Rng1 = Rng1.Offset(1, 0)
Set Rng = Rng.Offset(1, 0)
vrb = True
End If
Next sht
If vrb = False Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Left(Rng.Value, 31)
'Copy header rows (Re-code to dynamically set) to new worksheet first cell
Sheets("Sheet1").Range("A4:M4").Copy ActiveSheet.Range("A1")
Range("A2").Select
Do While Selection <> ""
ActiveCell.Offset(1, 0).Activate
Loop
Rng1.Copy ActiveCell
Set Rng1 = Rng1.Offset(1, 0)
Set Rng = Rng.Offset(1, 0)
End If
vrb = False
Loop
End Sub
Here's the updated code for anyone who stumbles across this question.
Public Sub Splitdatatosheets()
' Splitdatatosheets Macro
Dim rng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim vrb As Boolean
Dim sht As Worksheet
Dim R_Start, R_End, H_Start, H_End As Range
'Set Header
Set H_Start = Cells(4, 1)
Set H_End = H_Start.End(xlToRight)
'Set Data range
Set R_Start = Cells(5, 1)
Set R_End = R_Start.End(xlToRight)
'Find unique value for splitting
Set rng = Sheets("Sheet1").Range("C5")
'Find starting row to copy
Set Rng1 = Range(R_Start, R_End)
Set Rng2 = Range(H_Start, H_End)
vrb = False
Do While rng <> ""
For Each sht In Worksheets
If sht.Name = Left(rng.Value, 31) Then
sht.Select
Range("A2").Select
Do While Selection <> ""
ActiveCell.Offset(1, 0).Activate
Loop
Rng1.Copy ActiveCell
ActiveCell.Offset(1, 0).Activate
Set Rng1 = Rng1.Offset(1, 0)
Set rng = rng.Offset(1, 0)
vrb = True
End If
Next sht
If vrb = False Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Left(rng.Value, 31)
'Copy header rows to new worksheet first cell
Rng2.Copy ActiveSheet.Range("A1")
Range("A2").Select
Rng1.Copy ActiveCell
Set Rng1 = Rng1.Offset(1, 0)
Set rng = rng.Offset(1, 0)
End If
vrb = False
Loop
End Sub
I am still very new at VBA and I am having trouble getting some code to work. I have one sub where I want to create worksheets based off of a list of names in a worksheet named AllCities. The list of city names starts in cell A2. The worksheets need to be named after the cell value in the list, and the list should be able to be updated. The code right now works kind of, but it doesn't add new worksheets if I add to the list of names. My second sub is supposed to delete an any worksheets that do not correspond to a city on the list. My delete sub is just deleting every worksheet right now.
Insert Worksheet Code:
Sub insertSheets()
Dim myCell As Range
Dim MyRange As Range
Dim MyRange2 As Range
Set MyRange = Sheets("AllCities").Range("A2")
Set MyRange2 = Range(MyRange, MyRange.End(xlDown))
For Each myCell In MyRange2
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = myCell.Value
Next myCell
End Sub
Delete Worksheet Code:
Sub deleteSheets()
Dim wks As Worksheet
Dim MyRange As Range
Dim myCell As Range
Set wks = Sheets("AllCities")
With wks
Set MyRange = Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With
On Error Resume Next
Application.DisplayAlerts = False
For Each myCell In MyRange
Sheets(myCell.Value).Delete
Next myCell
Application.DisplayAlerts = True
On Error GoTo 0
End Sub
Thanks for any help that you have!
You're attempting to use two different methods (that will yield different results) to find the last cell in the range.
In your insertSheets procedure, you're using:
Set MyRange2 = Range(MyRange, MyRange.End(xlDown))
This is the same effect as holding Ctrl and pressing the down key which will find the last cell before a blank cell is present.
In your deleteSheets procedure you use:
Set MyRange = Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
This has a different effect from the way you searched in the insertSheets procedure as it starts from the bottom of the worksheet to find the true last cell in the range.
I suggest amending your insertSheets procedure to:
Sub insertSheets()
Dim myCell As Range
Dim MyRange As Range
Dim MyRange2 As Range
With Sheets("AllCities")
Set MyRange = .Range("A2")
Set MyRange2 = .Range(MyRange, .Rows.Count, "A").End(xlUp)
End With
For Each myCell In MyRange2
If Not myCell.Value = vbNullString Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = myCell.Value
End If
Next myCell
End Sub
This will also validate that the cell is not blank and therefore prevent Excel from throwing an error because you trying to rename a new worksheet to having no name.