how to create multiple charts with vba - excel

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

Related

VBA Excel remove duplicate values based on values in other column

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

How to scroll to the top of each sheet in a loop

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?

Userform button not calling code on Module

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

How do I create a VBA Macro that can function when I send to my colleagues?

I have created a VBA code at work for a database which my colleagues and I will use to store data on cases that we are working on. However, when I share my Excel, the macro doesn't automatically work.
For it to work, my colleagues need to go into "Macros" and then change "Macros in:" to "(name of doc)" instead of being able to use the default setting "All Open Workbooks".
Is there a way for me to fix my original macro so when i share it with my colleagues the macro can run without the necessity to make adjustments for every input?
This question may be a bit "elementary" in this forum, but would be highly appreciative of any help.
Thanks!
p.s. Please let me know if you need any more information to diagnose this problem.
Private Sub CommandButton1_Click()
Range("A1").Value = Range("A1").Value + 1
End Sub
Sub Macro1()
'
' basic variable types: strings, integers & longs
Dim ws As Worksheet
Dim lastRow As Long
Dim financing As String
Dim compName As String
Dim wrkSht As Worksheet
Dim fortnr As String
Dim lr As Long
Set ws = Sheets("INPUT")
financing = ws.Range("B2").Value
compName = ws.Range("B3").Value
fortnr = compName & "-" & financing
lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row + 1
ws.Cells(lastRow, "B") = financing
ws.Cells(lastRow, "C") = compName
'
' ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
' ActiveWorkbook.Sheets(Worksheets.Count).Name = compName & "-" & financing
ActiveWorkbook.Worksheets("Template").Copy After:=Worksheets("Template")
ActiveWorkbook.Sheets("Template").Name = compName & "-" & financing
ActiveWorkbook.Sheets(compName & "-" & financing).Visible = xlSheetVisible
ActiveWorkbook.Sheets("Template (2)").Name = "Template"
ActiveWorkbook.Sheets(fortnr).Select
ActiveWorkbook.Sheets(fortnr).Range("C4").Value = financing
ActiveWorkbook.Sheets(fortnr).Range("C5").Value = compName
ws.Cells(lastRow, "D").Formula = "='" & fortnr & "'!$C$7"
ws.Cells(lastRow, "E").Formula = "='" & fortnr & "'!$C$15"
ws.Cells(lastRow, "F").Formula = "='" & fortnr & "'!$C$10"
ws.Cells(lastRow, "G").Formula = "='" & fortnr & "'!$C$11"
ws.Cells(lastRow, "H").Formula = "='" & fortnr & "'!$C$12"
ws.Cells(lastRow, "I").Formula = "='" & fortnr & "'!$C$6"
ws.Cells(lastRow, "J").Formula = "='" & fortnr & "'!$C$14"
ws.Cells(lastRow, "L").Formula = "='" & fortnr & "'!$C$19"
ws.Cells(lastRow, "M").Formula = "='" & fortnr & "'!$C$17"
ws.Cells(lastRow, "N").Formula = "='" & fortnr & "'!$C$21"
ws.Cells(lastRow, "O").Formula = "='" & fortnr & "'!$C$22"
ws.Cells(lastRow, "Q").Formula = "='" & fortnr & "'!$C$25"
ws.Cells(lastRow, "R").Formula = "='" & fortnr & "'!$C$26"
ws.Cells(lastRow, "S").Formula = "='" & fortnr & "'!$C$27"
ws.Cells(lastRow, "T").Formula = "='" & fortnr & "'!$C$28"
ws.Cells(lastRow, "U").Formula = "='" & fortnr & "'!$C$29"
ws.Cells(lastRow, "V").Formula = "='" & fortnr & "'!$C$30"
ws.Cells(lastRow, "W").Formula = "='" & fortnr & "'!$C$31"
ws.Cells(lastRow, "X").Formula = "='" & fortnr & "'!$C$32"
ws.Cells(lastRow, "K").Formula = "='" & fortnr & "'!$C$16"
ws.Cells(lastRow, "P").Formula = "='" & fortnr & "'!$C$20"
'ws.Cells(lastRow, "D") = Sheets(fortnr).Range("B6").Value
'ws.Cells(lastRow, "E") = Sheets(fortnr).Range("B7").Value
'ws.Cells(lastRow, "D") = Sheets(fortnr).Range("B6").Address
'ws.Cells(lastRow, "E") = Sheets(fortnr).Range("B7").Address
ActiveSheet.Hyperlinks.Add Anchor:=ws.Cells(lastRow, 1), Address:="", SubAddress:= _
"'" & fortnr & "'" & "!A1", TextToDisplay:="Check" 'Anchor: the place where the link will be
ActiveSheet.Hyperlinks.Add Sheets(compName & "-" & financing).Range("A1"), "", Sheets("INPUT").Name & "!A1", TextToDisplay:="Back to Input-sheet"
End Sub

How to match data between columns to do the comparasion

I do not really know how to explain this in a clear manner. Please see attached image
I have a table with 4 different columns, 2 are identical to each other (NAME and QTY). The goal is to compare the differences between the QTY, however, in order to do it. I must:
1. sort the data
2. match the data item by item
This is not a big deal with small table but with 10 thousand rows, it takes me a few days to do it.
Pleas help me, I appreciate.
My logic is:
1. Sorted the first two columns (NAME and QTY)
2. For each value of second two columns (NAME and QTY), check if it match with first two column. If true, the insert the value.
3. For values are not matched, insert to new rows with offset from the rows that are in first two columns but not in second two columns
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lastRow As Long, i As Long, newRow As Long
Dim aCell As Range, SrchRange As Range
Set ws = Sheets("Sheet1")
With ws
.Columns("A:B").Copy .Columns("G:G")
.Columns("G:H").Sort Key1:=.Range("G2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
lastRow = .Range("G" & Rows.Count).End(xlUp).Row
newRow = lastRow
Set SrchRange = .Range("G2:G" & lastRow)
lastRow = .Range("C" & Rows.Count).End(xlUp).Row
.Range("I1").Value = "NAME": .Range("J1").Value = "QTY"
For i = 2 To lastRow
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
Set aCell = SrchRange.Find(What:=.Range("C" & i).Value, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
.Range("I" & aCell.Row).Value = .Range("C" & i).Value
.Range("J" & aCell.Row).Value = .Range("D" & i).Value
Else
newRow = newRow + 1
.Range("I" & newRow).Value = .Range("C" & i).Value
.Range("J" & newRow).Value = .Range("D" & i).Value
End If
End If
Next
End With
End Sub
SNAPSHOT
Based on your above requirements, the logic totally changes and hence I am posting it as a different answer.
Also in your "This is Wonderful" snapshot above, there is a slight error. As per logic SAMPLE10 cannot come above SAMPLE11. It has to come after SAMPLE11.
See the below snapshot
And here is the code :)
Option Explicit
Sub sAMPLE()
Dim ws As Worksheet
Dim lastRow As Long, i As Long, newRow As Long, rw As Long
Dim aCell As Range, SrchRange As Range
Set ws = Sheets("Sheet1")
With ws
.Columns("A:B").Copy .Columns("G:G")
.Columns("G:H").Sort key1:=.Range("G2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
.Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
lastRow = .Range("G" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
.Range("H" & i).Value = GetLastNumbers(.Range("G" & i).Value)
If .Range("H" & i).Value <> 0 Then
.Range("G" & i).Value = Left(.Range("G" & i).Value, _
Len(.Range("G" & i).Value) - Len(.Range("H" & i).Value))
End If
Next i
.Columns("G:H").Sort key1:=.Range("H2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For i = 2 To lastRow
If .Range("H" & i).Value <> 0 Then _
.Range("G" & i).Value = .Range("G" & i).Value & .Range("H" & i).Value
Next i
.Columns("H:H").Delete
newRow = lastRow
Set SrchRange = .Range("G2:G" & lastRow)
lastRow = .Range("C" & Rows.Count).End(xlUp).Row
.Range("I1").Value = "NAME": .Range("J1").Value = "QTY"
For i = 2 To lastRow
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
Set aCell = SrchRange.Find(What:=.Range("C" & i).Value, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
.Range("I" & aCell.Row).Value = .Range("C" & i).Value
.Range("J" & aCell.Row).Value = Application.Evaluate("=SUMPRODUCT((C2:C" & lastRow _
& "=" & """" & .Range("C" & i).Value & """" & ")*(D2:D" & lastRow & "))")
Else
newRow = newRow + 1
.Range("I" & newRow).Value = .Range("C" & i).Value
.Range("J" & newRow).Value = .Range("D" & i).Value
End If
End If
Next
lastRow = .Range("G" & Rows.Count).End(xlUp).Row
For i = lastRow To 2 Step -1
If .Range("G" & i).Value = .Range("G" & i - 1).Value Then
.Range("H" & i - 1).Value = .Range("H" & i).Value + .Range("H" & i - 1).Value
If Application.WorksheetFunction.CountA(.Range("I" & i & ":J" & i)) = 0 Then
.Range("G" & i & ":J" & i).Delete Shift:=xlUp
Else
.Range("G" & i & ":H" & i).Delete Shift:=xlUp
End If
End If
Next i
lastRow = .Range("I" & Rows.Count).End(xlUp).Row
newRow = .Range("G" & Rows.Count).End(xlUp).Row
If lastRow <= newRow Then Exit Sub
.Range("I" & newRow & ":J" & lastRow).Sort key1:=.Range("I" & newRow), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For i = lastRow To newRow Step -1
If .Range("I" & i).Value = .Range("I" & i - 1).Value Then
.Range("J" & i - 1).Value = .Range("J" & i).Value + .Range("J" & i - 1).Value
.Range("I" & i & ":J" & i).Delete Shift:=xlUp
End If
Next i
End With
End Sub
Function GetLastNumbers(strVal As String) As Long
Dim j As Long, strTemp As String
For j = Len(strVal) To 1 Step -1
If Not IsNumeric(Mid(strVal, j, 1)) Then Exit For
strTemp = Mid(strVal, j, 1) & strTemp
Next j
GetLastNumbers = Val(Trim(strTemp))
End Function

Resources