I have a Userform with the following code attached to the "OK" button. All the code works fine other than the last 4 lines. Full code associated to OK button shown below, code not working is:
Dim SheetName As String
SheetName = ActiveSheet.Name
Call SheetCleanup
Worksheets(SheetName).Activate
It is as if it completely ignores it. SheetCleanup is located in a Module, and my suspicions are that there is an issue going from a Userform to a Module? But I am unfamiliar with this.
Full code is here:
Private Sub CommandButtonOK_Click()
If ComboBoxTargetEvent.Value = "" Or ComboBoxDesigner.Value = "" Or ComboBoxSignoff.Value = "" Or ComboBoxCarArea.Value = "" Or ComboBoxOriginator.Value = "" Or TextBoxNumberOfJobs.Value = "" Or ComboBoxProjectTitle.Value = "" Then _
MsgBox "You must complete all fields", vbInformation
Else:
'Go to worksheet based on Car Area
Dim CarArea As String
CarArea = ComboBoxCarArea.Value
Worksheets(CarArea).Activate
'Enter Target Event Into Column A
Columns("A").Find("", Cells(Rows.Count, "A")).Value = ComboBoxTargetEvent.Value
'Enter Project Title into column B
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 1).Value = ComboBoxProjectTitle.Value
'Enter Designer name into column E
If _
ComboBoxDesigner.Value <> "Various" Then _
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 4).Value = ComboBoxDesigner.Value
'Enter Sign-off name into column F
If _
ComboBoxSignoff.Value <> "Various" Then _
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 5).Value = ComboBoxSignoff.Value
'Enter Originator name into column F
If _
ComboBoxOriginator.Value <> "Various" Then _
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 3).Value = ComboBoxOriginator.Value
'Enter Data Formula into columns H & I
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-2, 7).Select
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-2, 7).Copy
Selection.Offset(1, 0).PasteSpecial Paste:=xlPasteFormulas
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-2, 8).Select
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-2, 8).Copy
Selection.Offset(1, 0).PasteSpecial Paste:=xlPasteFormulas
'Enter temp values into C & G
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 2).Value = "ENTER DESCRIPTION HERE (CAPS LOCK ONLY)"
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 6).Value = "ENTER DATE"
'Enter "N" into Job Completed
Columns("A").Find("", Cells(Rows.Count, "A")).Offset(-1, 9).Value = "N"
'Enter Data Validation List for Target Event
Dim ws As Worksheet
Dim NumberOfJobs As Long
Dim LastUsedInAA As Long
Dim range9 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range9 = ws.Range("a:a")
LastUsedInAA = Range("A" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("A" & LastUsedInAA).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete 'delete previous validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range9.Address
End With
End If
'Enter Data Validation List for Designer
Dim LastUsedInE As Long
Dim range1 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range1 = ws.Range("c:c")
LastUsedInE = Range("E" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("E" & LastUsedInE).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete 'delete previous validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range1.Address
End With
End If
'Enter Data Validation List for Senior Designer
Dim LastUsedInF As Long
Dim range2 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range2 = ws.Range("b:b")
LastUsedInF = Range("F" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("F" & LastUsedInF).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range2.Address
End With
End If
'Enter Data Validation List for Originator
Dim LastUsedInD As Long
Dim range5 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range5 = ws.Range("f:f")
LastUsedInD = Range("D" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("d" & LastUsedInD).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range5.Address
End With
End If
'Enter Data Validation List for Job Completed
Dim LastUsedInJ As Long
Dim range3 As Range
Set ws = ThisWorkbook.Worksheets("VBA_Data")
Set range3 = ws.Range("d:d")
LastUsedInJ = Range("J" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 0 Then
Range("J" & LastUsedInJ).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 1, _
Selection.Columns.Count).Select
With Selection.Validation
.Delete 'delete previous validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & range3.Address
End With
End If
'Multiply rows for multiple jobs
Dim LastUsedInA As Long
LastUsedInA = Range("A" & Rows.Count).End(xlUp).Row
NumberOfJobs = TextBoxNumberOfJobs.Value
If NumberOfJobs <> 1 Then
Range("A" & LastUsedInA).Select
Selection.Resize(Selection.Rows.Count, _
Selection.Columns.Count + 10).Copy
Range("A" & LastUsedInA + 1).Select
Selection.Resize(Selection.Rows.Count + NumberOfJobs - 2, _
Selection.Columns.Count).Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormulas
End If
'Clear the clipboard
Application.CutCopyMode = False
'select last cell in A
Range("A" & LastUsedInA).Select
'Clear all fields before hide
ComboBoxTargetEvent.Value = ""
ComboBoxDesigner.Value = ""
ComboBoxSignoff.Value = ""
ComboBoxCarArea.Value = ""
ComboBoxOriginator.Value = ""
TextBoxNumberOfJobs.Value = ""
ComboBoxProjectTitle.Value = ""
'Hide Window
CreateJobs.Hide
End If
Dim SheetName As String
SheetName = ActiveSheet.Name
Call SheetCleanup
Worksheets(SheetName).Activate
End Sub
Code for SheetCleanup is as follows:
Public Sub SheetCleanup()
'Clan-up on Car Area WorkSheets
Application.ScreenUpdating = False
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
Select Case sh.Name
Case Is = "Contents Page", "Completed", "VBA_Data", "Front Team Project List", "Mid Team Project List", "Rear Team Project List", "Acronyms"
Case Else
With sh
'set zoom
sh.Activate
ActiveWindow.Zoom = 100
'format columns and rows
.Columns("g:g").NumberFormat = "dd-mm"
.Columns("i:i").NumberFormat = "0"
.Columns("A").ColumnWidth = 27
.Columns("B").ColumnWidth = 50
.Columns("C").ColumnWidth = 50
.Columns("D").ColumnWidth = 21
.Columns("E").ColumnWidth = 27
.Columns("F").ColumnWidth = 21
.Columns("G").ColumnWidth = 10
.Columns("H").ColumnWidth = 15
.Columns("I").ColumnWidth = 22
.Columns("J").ColumnWidth = 17
.Rows("1").RowHeight = 77.2
.Rows("2").RowHeight = 10
.Rows("3").RowHeight = 30
.Rows("4").RowHeight = 10
.Rows("5").RowHeight = 18
.Columns("a:j").HorizontalAlignment = xlCenter
.Columns("b:c").HorizontalAlignment = xlLeft
.Rows("3").HorizontalAlignment = xlCenter
.Rows("5").HorizontalAlignment = xlCenter
.Range("A:J").Validation.Delete
'set data validation for Target Event
Dim ws As Worksheet
Dim wsVBA As Worksheet
Dim range1 As Range, rng As Range
Dim LastRowTargetEvent As Long
Set wsVBA = ThisWorkbook.Worksheets("VBA_Data")
LastRowTargetEvent = wsVBA.Cells(.Rows.Count, "A").End(xlUp).Row
Set range1 = wsVBA.Range("A2:A" & LastRowTargetEvent)
Set ws = ActiveSheet
Set rng = ws.Range("a6:a1000")
With rng.Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="='" & wsVBA.Name & "'!" & range1.Address
End With
End With
End Select
Next sh
End Sub
Related
I have several codes of the same. I can remove duplicates only for these ones, which have the H-column empty. If the H column contains nonempty cell, the given code must stay.
I tried to work with IsEmpty() function, but it didn't work. The behaviour was as normal.
The code looks like this:
If IsEmpty(shTarget.Range("H" & lRow)) Then
With shTarget.Range("A" & lRow)
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteFormats
.RemoveDuplicates Columns:=1, Header:=xlYes
.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
.WrapText = True
End With
End If
The approach with:
If shTarget.Range("H" & lRow) = "" Then
was exactly the same.
How can I retain the duplicate codes, which have value in other column?
UPDATE:
With this approach:
With shTarget.Range("A" & lRow)
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteFormats
If .Range("H" & lRow).Value = "" Then
.RemoveDuplicates Columns:=1, Header:=xlYes
End If
.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
.WrapText = True
End With
I have an error:
Sort method of Range class failed
UPDATE II
Tried also have this one:
For Each r In rng
If r.Value = "" Then
shTarget.Range("A2:H" & lRow).RemoveDuplicates Columns:=1,
Header:=xlYes
End If
Next r
it still doesn't work. Basically, no difference was observed.
My full code is:
Sub CopyData_Cables(ByRef shSource As Worksheet, shTarget As Worksheet)
Const VHead As String = "A1:H1"
Const VMBom As String = "A2:H100"
shSource.Range(VHead).Copy
With shTarget.Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
Dim lRow As Long, lRow2 As Long
Dim i As Integer
lRow = shTarget.Cells(Rows.Count, "A").End(xlUp).Row + 1
shSource.Range(VMBom).Copy
Set Rng = shTarget.Range("H2" & lRow)
If IsEmpty(shTarget.Range("H" & lRow)) Then
With shTarget.Range("A" & lRow)
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteFormats
.RemoveDuplicates Columns:=1, Header:=xlYes
.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
.WrapText = True
End With
End If
'If shTarget.Range("H2" & lRow) <> "" Then
'shTarget.Range("A" & lRow).Value = 0
'End If
'For Each r In Rng
' If r.Value = "" Then
'shTarget.Range("A2:A" & lRow).Value = "Kurs!"
' End If
' Next r
shTarget.Columns("A").ColumnWidth = 6.11
shTarget.Columns("B").ColumnWidth = 50
shTarget.Columns("C").ColumnWidth = 50
shTarget.Columns("D").ColumnWidth = 5.44
shTarget.Columns("E").ColumnWidth = 5.89
shTarget.Columns("F").ColumnWidth = 9
shTarget.Columns("G").ColumnWidth = 21.22
shTarget.Columns("H").ColumnWidth = 10.89
shTarget.Rows.EntireRow.AutoFit
For i = 3 To lRow Step 4
shTarget.Range(shTarget.Cells(i, 1), shTarget.Cells(i, 5)).Interior.Color = RGB(235, 235, 235)
shTarget.Range(shTarget.Cells(i, 7), shTarget.Cells(i, 8)).Interior.Color = RGB(235, 235, 235)
Next i
' Reset the clipboard.
Application.CutCopyMode = xlCopy
End Sub
Scan up the sheet deleting the duplicate rows.
Option Explicit
Sub RemoveDuplicates()
Dim ws As Worksheet, dict
Dim lastrow As Long, i As Long, n As Long
Dim key As String
Dim fso, ts
Set fso = CreateObject("Scripting.FilesystemObject")
Set ts = fso.CreateTextFile("debug.txt")
Set dict = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = lastrow To 2 Step -1
If Len(Trim(.Cells(i, "H"))) = 0 Then
key = Trim(.Cells(i, "A"))
If dict.exists(key) Then
'.Cells(i, "A").Interior.Color = vbRed
.Rows(i).Delete
n = n + 1
Else
dict.Add key, i
End If
Else
key = ""
End If
ts.writeline i & " A='" & .Cells(i, "A") & "' H='" _
& .Cells(i, "H") & "' key='" & key & "' n=" & n
Next
End With
ts.Close
MsgBox n & " rows deleted", vbInformation
End Sub
I need some help.... I have this code in sheet1:
Sheets("kips").Select
Dim i As Integer 'rows
Dim j As Integer 'columns
i = Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To 5
With ActiveSheet.Shapes.AddChart.Chart
.Parent.Name = "Chart_" & (j - 1)
.ChartType = xlColumnClustered
.SeriesCollection.NewSeries
With .SeriesCollection(1)
'.Name = "=" & ActiveSheet.Name & "!" & _
'Cells(1, j).Address
.XValues = "=" & ActiveSheet.Name & "!" & _
Range(Cells(2, 1), Cells(i, 1)).Address
.Values = "=" & ActiveSheet.Name & "!" & _
Range(Cells(2, j), Cells(i, j)).Address
End With
End With
Next j
And I need to add new charts in an other sheet, so I tried to use the same code:
Sheets("sheet2").Select
Dim i As Integer 'rows
Dim j As Integer 'columns
i = Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To 5
With ActiveSheet.Shapes.AddChart.Chart
.Parent.Name = "Chart_" & (j - 1)
.ChartType = xlColumnClustered
.SeriesCollection.NewSeries
With .SeriesCollection(1)
'.Name = "=" & ActiveSheet.Name & "!" & _
'Cells(1, j).Address
.XValues = "=" & ActiveSheet.Name & "!" & _
Range(Cells(2, 1), Cells(i, 1)).Address
.Values = "=" & ActiveSheet.Name & "!" & _
Range(Cells(2, j), Cells(i, j)).Address
End With
End With
Next j
Is the same model of the tabel, but I need to put this in another sheet, here is my tabel:
What I am doing wrong?
Thank you
When working with sheets it's always a good idea to create sheet variables, assign them to the sheets you're working with, and then use those variables instead of referring to sheets via their name, or "Select sheet >> ActiveSheet" etc
Dim i As Long 'use Long
Dim j As Long
Dim wsCht As Worksheet, wsData As Worksheet
Set wsData = ActiveSheet
Set wsCht = ThisWorkbook.Sheets("Sheet2")
i = wsData.Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To 5
With wsCht.Shapes.AddChart.Chart
.Parent.Name = "Chart_" & (j - 1)
.ChartType = xlColumnClustered
.SeriesCollection.NewSeries
With .SeriesCollection(1)
'.Name = "=" & wsData.Name & "!" & wsdata.Cells(1, j).Address
.XValues = "='" & wsData.Name & "'!" & _
wsData.Range(wsData.Cells(2, 1), wsData.Cells(i, 1)).Address
.Values = "='" & wsData.Name & "'!" & _
wsData.Range(wsData.Cells(2, j), wsData.Cells(i, j)).Address
End With
End With
Next j
I'm running a macro to loop through 7 worksheets. However, once it's saved and I go to the first worksheet, I'm at the bottom of the table.
I've tried different lines to try and scroll back to the top of all the worksheets within the loop, and none seem to work.
I've tried:
ActiveWindow.ScrollRow = 1
Application.Goto Reference:=Range("A1"), Scroll:=True
I know you shouldn't use select, but I've also tried: .Range("A1").Select
Any ideas?
Sub BrandRank_Pints_IceCream()
Dim Wb As Workbook
Dim Ws As Worksheet
Dim Tbl As ListObject
Dim Rng As Range ' range in which to set the table
Dim Rl As Long ' last row
Dim Cl As Long ' last column
For Each Ws In ActiveWorkbook.Worksheets
With Ws
If .Index <> 1 Then
'Combine Bear and Dog Data & Delete Rows
'Find the last used row in Column A
Dim RngA As Long
RngA = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row
'Add Text in Column A, B, and C
.Cells(RngA, "A").Value = "Blue"
.Cells(RngA, "B").Value = "Red"
.Cells(RngA, "C").Value = "TEST"
'Combine Data containing 'Bear*' and 'Dog*' data
Dim RngTest As Range
Set RngTest = .Range("C:C").Find("Test", LookIn:=xlValues, Lookat:=xlWhole)
RngTest.Offset(0, 1).Formula = "=sum(sumifs(D:D, C:C, {""Bear*"" , ""Dog*""}))"
RngTest.Offset(0, 2).Formula = "=sum(sumifs(E:E, C:C, {""Bear*"" , ""Dog*""}))"
RngTest.Offset(0, 3).Formula = "=sum(sumifs(F:F, C:C, {""Bear*"" , ""Dog*""}))"
RngTest.Offset(0, 5).Formula = "=sum(sumifs(H:H, C:C, {""Bear*"" , ""Dog*""}))"
RngTest.Offset(0, 6).Formula = "=sum(sumifs(I:I, C:C, {""Bear*"" , ""Dog*""}))"
RngTest.Offset(0, 7).Formula = "=sum(sumifs(J:J, C:C, {""Bear*"" , ""Dog*""}))"
RngTest.Offset(0, 8).Formula = "=sum(sumifs(L:L, C:C, {""Bear*"" , ""Dog*""}))"
RngTest.Offset(0, 10).Formula = "=sum(sumifs(M:M, C:C, {""Bear*"" , ""Dog*""}))"
RngTest.EntireRow.Copy
RngTest.EntireRow.PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Filter "Bear*" and "Dog*", and Delete Rows
Dim DataLastRow As Long
DataLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'Apply Filter
.Range("A3:M3").AutoFilter Field:=3, Criteria1:=Array("Bear*"" , ""Dog"), Operator:=xlFilterValues
'Delete Rows
.Range("A4:M" & DataLastRow).EntireRow.Delete
'Clear Filter
.AutoFilter.ShowAllData
.Cells.AutoFilter
'Replace Test for Bear/Dog
RngTest.Replace "Test", "BEAR/DOG"
'Insert Table with the Data starting in Column A3:M
' find the last used row in column A
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
' find the last used column in row 3
Cl = .Cells(3, .Columns.Count).End(xlToLeft).Column
' set the range for the table
Set Rng = .Range(.Cells(3, "A"), .Cells(Rl, Cl))
' convert the range to a table
Set Tbl = .ListObjects.Add(xlSrcRange, Rng, , xlYes)
'Remove / Change Table Format
With Tbl
.Name = .Name & "_Table"
.Range.ClearFormats
.TableStyle = "TableStyleMedium10"
.Range.Font.Bold = True
.Range.Font.Size = 16
'Apply a filter to $ Share for all Brands (Largest to Smallest)
.AutoFilter.Sort.SortFields.clear
.AutoFilter.Sort.SortFields.Add2 Key:=Range("D3"), SortOn:=xlSortOnValues, Order:=xlDescending
.AutoFilter.ApplyFilter
.ShowAutoFilterDropDown = False
End With
'Update $ - % Chg Formula
.Range("G4").Formula = "=IFERROR((F4/(F4-H4))-1,"""")"
.Range("G4").NumberFormat = "0.0%"
.Range("G4").AutoFill Destination:=.Range("G4:G" & DataLastRow)
'Update Units - % Chg Formula
.Range("L4").Formula = "=IFERROR((K4/(K4-M4))-1,"""")"
.Range("L4").NumberFormat = "0.0%"
.Range("L4").AutoFill Destination:=.Range("L4:L" & DataLastRow)
'Insert 3 Rows
.Rows("20:22").Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Range("C20").Value = "ALL OTHER"
.Range("C21").Value = "GRAND TOTAL"
'Add Formulas to ALL OTHER
Dim aOther As Range
Set aOther = .Range("C:C").Find("All Other", LookIn:=xlValues, Lookat:=xlWhole)
aOther.Offset(0, 1).Formula = "=SUM(" & aOther.Offset(3, 1).Address & ":" & .Cells(DataLastRow, 4).Address & ")"
aOther.Offset(0, 2).Formula = "=SUM(" & aOther.Offset(3, 2).Address & ":" & .Cells(DataLastRow, 5).Address & ")"
aOther.Offset(0, 3).Formula = "=SUM(" & aOther.Offset(3, 3).Address & ":" & .Cells(DataLastRow, 6).Address & ")"
aOther.Offset(0, 5).Formula = "=SUM(" & aOther.Offset(3, 5).Address & ":" & .Cells(DataLastRow, 8).Address & ")"
aOther.Offset(0, 6).Formula = "=SUM(" & aOther.Offset(3, 6).Address & ":" & .Cells(DataLastRow, 9).Address & ")"
aOther.Offset(0, 7).Formula = "=SUM(" & aOther.Offset(3, 7).Address & ":" & .Cells(DataLastRow, 10).Address & ")"
aOther.Offset(0, 8).Formula = "=SUM(" & aOther.Offset(3, 8).Address & ":" & .Cells(DataLastRow, 11).Address & ")"
aOther.Offset(0, 10).Formula = "=SUM(" & aOther.Offset(3, 10).Address & ":" & .Cells(DataLastRow, 13).Address & ")"
'Add Formulas to Grand Total
.Range("F21").Formula = "=Sum(F4:F20)"
.Range("H21").Formula = "=Sum(H4:H20)"
.Range("K21").Formula = "=Sum(K4:K20)"
.Range("M21").Formula = "=Sum(M4:M20)"
'Update Column Format
.Columns("D").NumberFormat = "0.0"
.Columns("E").NumberFormat = "0.0"
.Columns("F").NumberFormat = "$#,##0"
.Columns("H").NumberFormat = "$#,##0"
.Columns("I").NumberFormat = "0.0"
.Columns("J").NumberFormat = "0.0"
.Columns("K").NumberFormat = "#,##0"
.Columns("M").NumberFormat = "#,##0"
.Range("D3").Value = "$ SHARE"
.Range("E3").Value = "$ SHARE CHG"
.Range("F3").Value = "$"
.Range("G3").Value = "$ - % CHG"
.Range("H3").Value = "$ - ABS CHG"
.Range("I3").Value = "UNITS SHARE"
.Range("J3").Value = "UNITS SHARE CHG"
.Range("K3").Value = "UNITS"
.Range("L3").Value = "UNITS - % CHG"
.Range("M3").Value = "UNITS - ABS CHG"
.Columns("D:M").EntireColumn.HorizontalAlignment = xlCenter
.Columns("D:M").EntireColumn.AutoFit
'Highlight Grand Total Row
Dim gTotal As Range
Set gTotal = .Range("C:C").Find("Grand Total", LookIn:=xlValues, Lookat:=xlWhole)
With gTotal
.EntireRow.Interior.ThemeColor = xlThemeColorAccent2
.EntireRow.Font.ThemeColor = xlThemeColorDark1
End With
'Highlight BRAND Row
Dim Brand As Range
Set Brand = .Range("C:C").Find("BRAND", LookIn:=xlValues, Lookat:=xlWhole)
With Brand
Brand.Offset(0, -2).Resize(1, 13).BorderAround , xlThick, -11489280
End With
Application.Goto Reference:=Range("A1"), Scroll:=True
End If
End With
Next Ws
'Save File
Application.DisplayAlerts = False
Dim TemplatePath As String
TemplatePath = ""
ActiveWorkbook.SaveAs Filename:=TemplatePath & "BrandRank - Template" & ".xlsm", FileFormat:=52
Application.DisplayAlerts = True
End Sub
Please, try Ws.Activate: Ws.Range("A1").Select... Why scrolling?
Our company has 36 departments and we use a master budgeting worksheet to develop the budget. The department numbers are not sequential and their budgets are all different. I put together the following macro to send the worksheets to the individual departments. The master is full of VLOOKUPs and other formulae, but the individual departments receive only the final results and a couple of columns for their changes. They can make changes to any number that is not highlighted in yellow. The macro works perfectly for only one department, but when I tried to copy it 35 times below itself so that I could send a worksheet to all departments, I received an error message that said my procedure was too large. I divided it in half and I still received the message!
Sub Macro1()
'
' Macro1 Macro
'' Prepares O&M budget Worksheet for uploading
' Dim sourceSheet as Worksheet
Workbooks.Open Filename:="F:\Rick\2020 Budget\2020 O&M Budget.xlsx"
Set sourcesheet = Worksheets("Dept Detail-O&M Book")
sourcesheet.Activate
' Dim N As Long
' Dim T As Long
' Dim LastRow As Long
lastrow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
Dim i As Long, Total As Long
Dim cell As Range
Application.EnableEvents = False
'
Application.Goto Reference:="Dept_01"
Selection.Copy
Workbooks.Open Filename:="Q:\O&M\Departmental Budgets\Dept 1 MOEC.xlsx"
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
ThisWorkbook.Activate
Application.CutCopyMode = False
Selection.Copy
Windows("Dept 1 MOEC.xlsx").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("R1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Application.CutCopyMode = False
n = Cells(Rows.Count, "R").End(xlUp).Row
Cells(n, "R").Formula = "=SUM(R1:R" & n - 1 & ")"
activecell.Select
Selection.Copy
activecell.Offset(0, 2).Select
ActiveSheet.Paste
Selection.Copy
activecell.Offset(0, 2).Select
ActiveSheet.Paste
Range("X9").Select
activecell.FormulaR1C1 = "=iferror(+RC[-2]/RC[-10],0)"
Range("X9").Select
T = Cells(Rows.Count, "X").End(xlUp).Row
Selection.AutoFill Destination:=Range("x9:x" & T)
With ActiveSheet
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
Application.EnableEvents = False
For i = lastrow To 1 Step -1
If Range("B" & i).Value = "1010" Or _
Range("B" & i).Value = "1020" Or _
Range("B" & i).Value = "2172" Or _
Range("B" & i).Value = "2190" Or _
Range("B" & i).Value = "2200" Or _
Range("B" & i).Value = "2290" Or _
Range("B" & i).Value = "4020" Or _
Range("B" & i).Value = "4050" Or _
Range("B" & i).Value = "4060" Or _
Range("B" & i).Value = "4070" Or _
Range("B" & i).Value = "4090" Or _
Range("B" & i).Value = "4100" Or _
Range("B" & i).Value = "4110" Or _
Range("B" & i).Value = "4509" Or _
Range("B" & i).Value = "4510" Or _
Range("B" & i).Value = "4600" Or _
Range("B" & i).Value = "4610" Or _
Range("B" & i).Value = "4700" Or _
Range("B" & i).Value = "5710" Or _
Range("B" & i).Value = "5721" Or _
Range("B" & i).Value = "5723" Or _
Range("B" & i).Value = "5725" Or _
Range("B" & i).Value = "5729" Or _
Range("B" & i).Value = "5730" Or _
Range("B" & i).Value = "5731" Then
.Range("R" & i).Interior.Color = RGB(255, 255, 0)
.Range("T" & i).Interior.Color = RGB(255, 255, 0)
End If
Next i
Application.EnableEvents = True
End With
With ActiveSheet
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
Application.EnableEvents = False
For i = lastrow To 1 Step -1
If Range("B" & i).Value = "5721" Or _
Range("B" & i).Value = "9000" Or _
Range("B" & i).Value = "9005" Or _
Range("B" & i).Value = "9010" Or _
Range("B" & i).Value = "9030" Then
.Range("R" & i).Interior.Color = RGB(255, 255, 0)
.Range("T" & i).Interior.Color = RGB(255, 255, 0)
End If
Next i
Application.EnableEvents = True
End With
Range("A1").Select
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
Could someone offer suggestions on how to reduce the size of the macro and/or make it more efficient? Thanks!
I took a shot at cleaning this up (at least to make it run, for now) - I don't know enough about what you're doing to clean up that mid section, though. The problem undoubtedly was that long If statement.
Instead of all the Ors, put all your values in an array then test against that array with IsError:
Option Explicit
Sub Macro1()
Dim valuearr As Variant
Dim cell As Range
Dim sourcesheet As Worksheet
Dim lastrow As Long, i As Long, n As Long
Workbooks.Open Filename:="F:\Rick\2020 Budget\2020 O&M Budget.xlsx"
Set sourcesheet = Worksheets("Dept Detail-O&M Book")
sourcesheet.Activate
lastrow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
Application.EnableEvents = False
'This section needs to be cleaned up...
Application.Goto Reference:="Dept_01"
Selection.Copy
Workbooks.Open Filename:="Q:\O&M\Departmental Budgets\Dept 1 MOEC.xlsx"
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
ThisWorkbook.Activate
Application.CutCopyMode = False
Selection.Copy
Windows("Dept 1 MOEC.xlsx").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("R1").Select
Selection.End(xlDown).Select
Application.CutCopyMode = False
n = Cells(Rows.Count, "R").End(xlUp).Row
Cells(n, "R").Formula = "=SUM(R1:R" & n - 1 & ")"
ActiveCell.Copy
ActiveCell.Offset(0, 2).Paste
Selection.Offset(0, 2).Select
ActiveSheet.Paste
Range("X9").FormulaR1C1 = "=iferror(+RC[-2]/RC[-10],0)"
Range("X9").AutoFill Destination:=Range("x9:x" & Cells(Rows.Count, "X").End(xlUp).Row)
With ActiveSheet
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
valuearr = Array(1010, 1020, 2172, 2190, 2200, 2290, 4020, 4050, 4060, 4070, 4090, 4100, 4110, 4509, 4510, 4600, 4610, 4700, 5710, 5721, 5723, 5725, 5729, 5730, 5731, 9000, 9005, 9010, 9030)
For i = lastrow To 1 Step -1
If IsError(Application.Match(Range("B" & i).Value, valuearr, 0)) Then
.Range("R" & i).Interior.Color = RGB(255, 255, 0)
.Range("T" & i).Interior.Color = RGB(255, 255, 0)
End If
Next i
End With
Application.EnableEvents = True
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
I am writing a vba macro to achieve the following but do not how to implement it. Would any please provide some guidance?
Currently, the data is as follows(subitem spans from column B onwards):
ITEM ONE [Subitem one... ]
ITEM ONE [Subitem two ...]
ITEM ONE [Subitem three...]
ITEM TWO [Subitem one ...]
ITEM THREE [Subitem one...]
ITEM Three [Subitem two...]
The following is what the data should look like in a separate sheet:
ITEM ONE
--------
Subitem one
Subitem two
Subitem three
ITEM TWO
--------
Subitem one
ITEM THREE
----------
Subitem one
Subitem two
Any guidance/help will be greatly appreciated.
Edited: solution as follows:
r = Range("a65536").End(xlUp).Row
c = Range("IU1").End(xlToLeft).Column
a = Split(Cells(, c).Address, "$")(1)
MsgBox "last row with data is " & r & " and last column with data is " & a & "", vbOKOnly, "LastRow and LastCol"
rr = r + 1
Application.Visible = False
Range("A1:" & a & r & "").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sheets("owssvr(1)").Select
Sheets.Add
'by default select first record and paste in reports sheet
Sheets("owssvr(1)").Select
Range("b2").Select
Selection.Copy
Sheets(1).Select
Range("b2").Select
ActiveSheet.Paste
'paste header below it
Sheets("owssvr(1)").Select
Range("c1:" & a & "2").Select
Selection.Copy
Sheets(1).Select
Range("b3").Select
ActiveSheet.Paste
For i = 3 To r
Sheets(2).Select
'Program name is same as above, dont copy name but row starting from next col, switch to other sheet, find last row in col B, add one to last row and paste
If Cells(i, 2).Value = Cells(i - 1, 2) Then
Range("C" & i & ":" & a & i & "").Select
Selection.Copy
Sheets(1).Select
'Range("b3").Select
lr2 = Range("b65536").End(xlUp).Row
Range("B" & lr2 + 1 & "").Select
ActiveSheet.Paste
Else
'if name is not same as above, copy name, find last row, add two to add a gap from prev program name, paste program name, move to next row and paste remaining cols
Sheets(2).Select
Range("B" & i & "").Select
Selection.Copy
Sheets(1).Select
lr2 = Range("b65536").End(xlUp).Row
Range("B" & lr2 + 2 & "").Select
ActiveSheet.Paste
'copy headers
Sheets(2).Select
Range("c1:" & a & "1").Select
Selection.Copy
Sheets(1).Select
lr2 = Range("b65536").End(xlUp).Row
Range("B" & lr2 + 1 & "").Select
ActiveSheet.Paste
'copy cells(row, col+1)
Sheets(2).Select
Range("C" & i & ":" & a & i & "").Select
Selection.Copy
Sheets(1).Select
'Range("b3").Select
lr2 = Range("b65536").End(xlUp).Row
Range("B" & lr2 + 1 & "").Select
ActiveSheet.Paste
End If
Next
What you're asking for can be done with a PivotTable. I'm working in Excel 2010, but 2003 should probably have the same functionality. This is how it would look like.
The naive VBA approach I was going to do (which I guess you've implemented) was looping through all the items, doing comparisons, and adding them one at a time to the new worksheet. This can be made a bit more efficient if you store the initial range (of 2 columns) in an array, loop through that and store the output in a 2nd array, then copy the array back to a range.
I'm not sure how much data you have or how long that operation takes. Another alternative would be to use the macro recorder to make a PivotTable and copy the data from there to a new sheet. Here's an example, though you'd want to change the worksheet and range references to make them explicit/dynamic. The example data range is A1:B9.
Sub Example()
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Sheets.Add
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Sheet1!R1C1:R9C2", Version:=xlPivotTableVersion14).CreatePivotTable _
TableDestination:="Sheet4!R3C1", TableName:="PivotTable1", DefaultVersion _
:=xlPivotTableVersion14
Sheets("Sheet4").Select
Cells(3, 1).Select
With ActiveSheet.PivotTables("PivotTable1").PivotFields("item1")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("sub12")
.Orientation = xlRowField
.Position = 2
End With
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
your old worksheet is called yourWorksheet.
create a new worksheet:
set newWS = thisworkbook.workbooks.add()
dim rr as long
rr =1
for r = startRow to yourWorksheet.UsedRange.Rows.Count
firstItem = yourWorksheet.cells(r,1).value
newWS.cells(rr,1).value = firstItem
rr = rr + 1
do while firstItem = yourworksheet.cells(r,1).value
newWS.cells(rr,1).value = yourworksheet.cells(rr,2).value 'copy all columns here
rr = rr + 1
r =r + 1
loop
next r
rough and untested, but that's the idea.
If you use the left command and extract the Item One, Item Two, etc.
Heading(row) = Left(Cells(row,"B"), 8)
then extract the subItem:
SubItem(row) = Left(Right(cells(row, "B"), 20), 10)
These will extract the text.
You have to get creative for THREE and FOUR.
Sub Sort1()
'
' Sort1 Macro
' Macro recorded 7/30/2012 by American International Group
'
'
Dim r As Integer
Dim c As Integer
Dim lr2 As Integer
Dim a As String
Dim b As String
Dim cdb As Long
Dim name1 As String
Dim name2 As String
n1 = InputBox(Prompt:="Enter a name for worksheet else click OK", Title:="Enter a name for this sheet", Default:="owssvr")
n2 = InputBox(Prompt:="Enter a name for the Report view sheet else click OK", Title:="Enter a name for Report sheet", Default:="reportView")
b = InputBox(Prompt:="Enter Column Name on which to sort data", Title:="Sort by", Default:="B")
b = UCase(b) 'convert to uppercase e.g.c to C
asciiCol = Asc(b) 'convert to ascii 66
asciiNext = asciiCol + 1 'add one to ascii to get next column ascii code e.g. 66+1=67 to get D
sortbyColNo = 0
sortbyColNo = Range(b & "1").Column
'Rename sheets to avoid conflict
Sheets(1).name = n1
Sheets("" & n1 & "").Select
r = Range("a65536").End(xlUp).Row
c = Range("IU1").End(xlToLeft).Column
a = Split(Cells(, c).Address, "$")(1)
x = Split(Cells(, c).Address, "$")(2)
MsgBox "last row with data is " & r & " and last column with data is " & a & "", vbOKOnly, "LastRow and LastCol"
rr = r + 1
'Application.Visible = False
Range("A1:" & a & r & "").Sort Key1:=Range("" & b & "2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sheets("" & n1 & "").Select
Sheets.Add
ActiveSheet.name = n2
'by default select first record and paste in reports sheet
Sheets("" & n1 & "").Select
Range("" & b & "2").Select
Selection.Copy
Sheets("" & n2 & "").Select
Range("b2").Select
ActiveSheet.Paste
'paste header below it
Sheets("" & n1 & "").Select
Range("" & Chr(asciiNext) & "1:" & a & "1").Select
With Selection
.Font.Bold = True
End With
Range("" & Chr(asciiNext) & "1:" & a & "2").Select
Selection.Copy
Sheets("" & n2 & "").Select
Range("b3").Select
ActiveSheet.Paste
'start from row 3
For i = 3 To r
Sheets("" & n1 & "").Select
'Program name is same as above, dont copy name but row starting from next col, switch to other sheet, find last row in col B, add one to last row and paste
If Cells(i, sortbyColNo).Value = Cells(i - 1, sortbyColNo) Then
Range("" & Chr(asciiNext) & "" & i & ":" & a & i & "").Select
Selection.Copy
Sheets("" & n2 & "").Select
'Range("b3").Select
lr2 = Range("b65536").End(xlUp).Row
Range("B" & lr2 + 1 & "").Select
ActiveSheet.Paste
Else
'if name is not same as above, copy name, find last row, add two to add a gap from prev program name, paste program name, move to next row and paste remaining cols
Sheets("" & n1 & "").Select
Range("" & b & "" & i & "").Select
Selection.Copy
Sheets("" & n2 & "").Select
lr2 = Range("b65536").End(xlUp).Row
Range("B" & lr2 + 2 & "").Select
ActiveSheet.Paste
'copy headers
Sheets("" & n1 & "").Select
Range("" & Chr(asciiNext) & "1:" & a & "1").Select
Selection.Copy
Sheets("" & n2 & "").Select
lr2 = Range("b65536").End(xlUp).Row
Range("B" & lr2 + 1 & "").Select
ActiveSheet.Paste
'copy cells(row, col+1)
Sheets("" & n1 & "").Select
Range("" & Chr(asciiNext) & i & ":" & a & i & "").Select
Selection.Copy
Sheets("" & n2 & "").Select
'Range("b3").Select
lr2 = Range("b65536").End(xlUp).Row
Range("B" & lr2 + 1 & "").Select
ActiveSheet.Paste
End If
Next
'Application.Visible = True
'formatSheet
End Sub