I am looking to split data from my master worksheet but retain said data on the same excel book. I need a new worksheet created based on a range of cells i.e. C2:C19 from master (I have been able to do this using the following code).
Sub CreateSheetsFromAList()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Master").Range("C2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
End Sub
For each new worksheet that is created I would like the headings and all data within the relevant row on Master pasted onto the new worksheet. i.e C2 = 10, Worksheet name 10 with headers A1 - Q1 from Master and all data from A2 - Q2 I then need each additional worksheet to do the same based on the C detail
I am very new to VBA and will be looking to take some training, in the meantime please help.
Thanks,
Paul.
Sub CreateSheetsFromAList()
Dim startsheet As Worksheet
Dim newsheet As Worksheet
Dim MyCell As Range, MyRange As Range
Set startsheet = Sheets("Sheet1")
Set MyRange = startsheet.Range("C2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Set newsheet = Sheets.Add(After:=Sheets(Sheets.Count))
Sheets(Sheets.Count).Name = MyCell.Value
startsheet.Rows(1).Copy newsheet.Range("a1")
MyCell.EntireRow.Copy newsheet.Range("a2")
Next MyCell
End Sub
Related
I have 4 sheets in total that need to be used.
ServerList1
ServerList2
MachineList1
MachineList2
The sheet names with a (1) next to them are the reports from last week and the sheet names with a (2) next to them are the reports from this week.
In each sheet, there are multiple columns which I get rid of so that all that remains is the column with either the Server Name or the Machine Name
Essentially, I need to compare last weeks report with this weeks report and see what new servers have been added (if any) and what new machines have been added (if any).
Conversely, I need to do the opposite, check what servers have been removed (if any) and what machines have been removed (if any)..
With the below code, it should be simple to accomplish the second part simply by switching the worksheet names..
I found the below code here:
https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/145223-compare-2-columns-in-different-sheets-and-copy-entire-rows-into-new-sheets
This code does a comparison and copies the new appearances, but there's two issues I am currently experiencing:
1) The code looks like it gets stuck in an infinite loop - I need to exit the code manually
2) On the New Servers-Machines sheet, the results are pasted from row A2 instead of A1
Sub compareSheets()
ThisWorkbook.RefreshAll
Dim rng As Range, c As Range, cfind As Range
Dim ws1 As Worksheet
Set ws1 = Worksheets("New Servers-Machines")
On Error Resume Next
With Worksheets("Last Week Servers")
Set rng = .Range(.Range("A1"), .Range("c1").End(xlDown))
For Each c In rng
c = Replace(c, " ", "")
With Worksheets("This Week Servers")
Set cfind = .Columns("A:A").Cells.Find(what:=c.Value, lookat:=xlWhole)
If cfind Is Nothing Then
c.Resize(1, 1).EntireRow.Copy
ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End With
Next c
Application.CutCopyMode = False
End With
With Worksheets("This Week Servers")
Set rng = .Range(.Range("A1"), .Range("c1").End(xlDown))
For Each c In rng
c = Replace(c, " ", "")
With Worksheets("Last Week Servers")
Set cfind = .Columns("A:A").Cells.Find(what:=c.Value, lookat:=xlWhole)
If cfind Is Nothing Then
c.Resize(1, 1).EntireRow.Copy
ws1.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End With
Next c
Application.CutCopyMode = False
End With
End Sub
UPDATE:
Public Sub FindDifferences1()
Dim firstRange As Range
Dim secondRange As Range
Dim myCell As Range
Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet
'Find Removed Wintel Servers
Set wks1 = ActiveWorkbook.Sheets("Last Week Servers List")
Set wks2 = ActiveWorkbook.Sheets("This Week Servers List")
Set wks3 = ActiveWorkbook.Sheets("New Servers")
Set firstRange = wks1.Range("A:A")
Set secondRange = wks2.Range("A:A")
For Each myCell In firstRange
If myCell <> secondRange.Range(myCell.Address) Then
myCell.Copy
wks3.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
wks3.Cells(Rows.Count, 2).End(xlUp).PasteSpecial xlPasteFormats
End If
Next myCell
End Sub
Format of the sheets is only one column with a row header Server Name
Let's assume that you have 3 worksheets:
worksheet1 - to compare with worksheet2
worksheet2 - to compare with worksheet1
worksheet3 - to write the values, which are different in worksheet1
Then some simple code as this one works quite ok:
Public Sub FindDifferences()
Dim firstRange As Range
Dim secondRange As Range
Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
Dim wks3 As Worksheet: Set wks3 = Worksheets(3)
Set firstRange = wks1.UsedRange
Set secondRange = wks2.UsedRange
Dim myCell As Range
For Each myCell In firstRange
If myCell <> secondRange.Range(myCell.Address) Then
wks3.Range(myCell.Address) = myCell
End If
Next myCell
End Sub
What does it do?
if loops through every cell of the UsedRange in Worksheets(1) and it compares it with the same cell in Worksheets(2);
if the comparison is different, then it writes the cell from Worksheets(1) in Worksheets(3);
you may consider coloring the cell in Worksheets(1), if different as well;
If your columns are on different places, thus you would like to compare column B with column D, then a bit crunching of the ranges is needed:
Set firstRange = wks1.UsedRange.Columns(2).Cells
Set secondRange = wks1.UsedRange.Columns(4).Cells
For Each myCell In firstRange
If myCell.Value2 <> secondRange.Cells(myCell.Row, secondRange.Column).Value2 Then
wks3.Range(myCell.Address) = myCell.Value2
End If
Next myCell
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
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 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 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.