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.
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 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
Hi I'm trying to create a copy of a worksheet in a workbook for each entry in a range, then rename the worksheet based on the value of the current cell in that range. It was working before, but now it doesn't name the new sheets. If I make blank worksheets, it will name them, however if I copy the worksheet it won't name the worksheet properly. I am also trying to set the value of C1 on each sheet to the value that is from the range. Below is my code:
Sub CreateSEMSheets()
On Error GoTo GetOut
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Strategic End Market Data").Range("SEMListGenerated")
For Each MyCell In MyRange
If MyCell.Value = "" Then GoTo GetOut
Sheets("StrategicMktPlan").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "SMP - " & MyCell.Value
Sheets(Sheets.Count).Range("C1").Value = MyCell.Value
Next MyCell
GetOut:
End Sub
Please help!!! Thanks in advance.
Edit: I figured out why it's not working - there was a hidden sheet that was the last sheet in the workbook and it was renaming that over and over. Any idea how to prevent this?
After Copy() method of Worksheet object the newly created worksheet is the active one:
For Each MyCell In MyRange
If MyCell.Value = "" Then GoTo GetOut
Sheets("StrategicMktPlan").Copy After:=Sheets(Sheets.Count)
With ActiveSheet
.Name = "SMP - " & MyCell.Value
.Range("C1").Value = MyCell.Value
End With
Next MyCell
Per your edit, you could use this:
Sub VisibleSheetsCount()
'UpdatebyKutoolsforExcel20150909
' https://www.extendoffice.com/documents/excel/3187-excel-count-visible-sheets.html
Dim xSht As Variant
Dim I As Long
For Each xSht In ActiveWorkbook.Sheets
If xSht.Visible Then I = I + 1
Next
MsgBox I & " sheets are visible", , "Kutools for Excel"
End Sub
Then do .Copy(After:=Sheets(I)) I think would work.
I'm trying to copy a column to the right of table and paste the formulas only (not values).
Sub acrescentaCols()
Dim oSheet As Worksheet
Set oSheet = Sheets("Sheet1")
oSheet.Columns("D:D").Select
Selection.Copy
Range(Selection, Selection.End(xlToRight)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
But this is copying also the values (because Excel considers values to be a formula too).
How do I fix this?
The below should fix your immediate problem of only copying the formulas across and not the values, but I'm not sure exactly what you're trying to do. If you can give more information I'm sure I can help you acheive what you're trying to get to.
It seems as if you want to copy the formulae to every row to the right of column D to the very right edge of the worksheet?
It also seems like you want to copy the formulae only so they re-evaluate in their new location - or do you want to past values only so that they hold the same values that they evaluated to in column D?
Anyway, give this a whirl.
Sub acrescentaCols()
Dim oSheet As Worksheet
Set oSheet = Sheets("Sheet1")
For Each cell In oSheet.Range("D1", Range("D1").End(xlDown))
If cell.HasFormula = True Then
cell.Copy
Range(cell.Address, Range(cell.Address).End(xlToRight)).PasteSpecial Paste:=xlPasteFormulas
End If
Next cell
End Sub
As per my comments earlier:
Sub acrescentaCols()
Dim oSheet As Worksheet
Dim rng As Range
Dim cel As Range
Set oSheet = Sheets("Sheet1")
With oSheet
Set rng = .Range(.Range("D1"), .Range("D" & .Rows.Count).End(xlUp))
For Each cel In rng
If Left(cel.Formula, 1) = "=" Then
Range(cel.Offset(, 1), cel.Offset(, 1).End(xlToRight)).Formular1c1 = cel.Formular1c1
End If
Next cel
End With
End Sub
When you say paste the formula only - your method will paste the formula and then recalculate and your formula will show the result. I think a better way to write that would be:
Sub acrescentaCols()
Dim oSheet As Worksheet
Dim rCopied As Range
Set oSheet = Sheets("Sheet1")
With oSheet
.Columns("D:D").Copy
Set rCopied = .Cells(1, 4).End(xlToRight).Offset(, 1).EntireColumn
rCopied.PasteSpecial Paste:=xlPasteFormulas
End With
End Sub
If you want to show the actual formula you could use a UDF something like:
Function GetFormula(Target As Range) As String
If Target.HasFormula Then
GetFormula = Target.Formula
End If
End Function
If you want to apply this to a whole column you could use:
Sub acrescentaCols1()
Dim oSheet As Worksheet
Dim rCopied As Range
Set oSheet = Sheets("Sheet1")
With oSheet
Set rCopied = .Cells(1, 4).End(xlToRight).Offset(, 1).EntireColumn
rCopied.FormulaR1C1 = "=GETFORMULA(RC4)"
End With
End Sub
This will probably kill your spreadsheet though - it will execute the UDF on all rows.
Sub acrescentaCols()
Dim oSheet As Worksheet, rng1 As Range, rng2 As Range, rng As Range
Set oSheet = Sheets("Sheet1")
Set rng1 = oSheet.Columns("D:D")
Set rng1 = Intersect(rng1, rng1.Worksheet.UsedRange) 'for the used range only
Set rng2 = Range(rng1, rng1.End(xlToRight))
For i = 1 To rng1.Cells.Count 'for each row
If Left(rng1(i, 1).Formula, 1) = "=" Then 'if it starts with an equal sign
For j = 1 To rng2.Columns.Count 'then for each column in the copy
rng2(i, j).FormulaR1C1 = rng1(i, 1).FormulaR1C1
Next j
End If
Next i
End Sub
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