I was wondering if my code could be simpelfied - excel

I've created some code to let users fill in a excelsheet with 4 tables. by pressing a button it copies the table data to another workbook. it has to find the last row filled and copy the data below that. Some cells won't get filled so i used .Filldown to get the empty cells filled. In order to make the .Filldown work i had to count the rows in the tables.
It all works but I'm new in VBA so i was wondering if my code can be simpelfied. It looks like a lot of code.
Private Sub CommandButton5_Click()
Dim PassWord As Variant
PassWord = InputBox("Wachtwoord?")
'PassWord = "Something"
If PassWord = "Something" Then
Dim nT1 As Integer
Dim nT2 As Integer
Dim nT3 As Integer
Dim nT4 As Integer
If Sheets("Variabelen").Range("H2") = 0 Then
Set Z = ActiveWorkbook.Sheets(1)
Set T1 = ActiveSheet.ListObjects("Tabel1").DataBodyRange
Set T1C = ActiveSheet.ListObjects("Tabel1")
Set T2 = ActiveSheet.ListObjects("Tabel2").DataBodyRange
Set T2C = ActiveSheet.ListObjects("Tabel2")
Set T3 = ActiveSheet.ListObjects("Tabel3").DataBodyRange
Set T3C = ActiveSheet.ListObjects("Tabel3")
Set T4 = ActiveSheet.ListObjects("Tabel4").DataBodyRange
Set T4C = ActiveSheet.ListObjects("Tabel4")
nT1 = T1C.Range.Rows.Count - 1
nT2 = T2C.Range.Rows.Count - 1
nT3 = T3C.Range.Rows.Count - 1
nT4 = T4C.Range.Rows.Count - 1
'Test_ verwijderen als bestand actief wordt
Set Y = Workbooks.Open("\\Somewhere\Test_Masterbestand Afdeling.xlsx")
'Huidige medewerker in opleiding (T1)
lRow = Y.Worksheets("Data").Cells(Y.Worksheets("Data").Rows.Count, 1).End(xlUp).Row
lRow = lRow + 1
T1.Copy
Y.Worksheets("Data").Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Y.Sheets("Data").Range("I" & lRow).Value = "Huidige medewerker in opleiding"
Y.Sheets("Data").Range("J" & lRow).Value = Z.Range("C3").Value
Y.Sheets("Data").Range("K" & lRow).Value = Z.Range("C4").Value
Y.Sheets("Data").Range("L" & lRow).Value = Z.Range("C6").Value
Dim LastRowA As Long
Dim LastRowB As Long
Dim LastRowC As Long
Dim LastRowD As Long
Dim LastRowE As Long
LastRowA = ActiveSheet.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowB = ActiveSheet.Range("I:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowC = ActiveSheet.Range("J:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowD = ActiveSheet.Range("K:K").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowE = ActiveSheet.Range("L:L").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
CopyrangeB = "I" & LastRowB & ":" & "I" & LastRowA
CopyrangeC = "J" & LastRowC & ":" & "J" & LastRowA
CopyrangeD = "K" & LastRowD & ":" & "K" & LastRowA
CopyrangeE = "L" & LastRowE & ":" & "L" & LastRowA
If nT1 > 1 Then
ActiveSheet.Range(CopyrangeB).FillDown
ActiveSheet.Range(CopyrangeC).FillDown
ActiveSheet.Range(CopyrangeD).FillDown
ActiveSheet.Range(CopyrangeE).FillDown
End If
'Nieuwe instroom in opleiding (T2)
lRow = Y.Worksheets("Data").Cells(Y.Worksheets("Data").Rows.Count, 1).End(xlUp).Row
lRow = lRow + 1
T2.Copy
Y.Worksheets("Data").Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Y.Sheets("Data").Range("I" & lRow).Value = "Nieuwe instroom in opleiding"
Y.Sheets("Data").Range("J" & lRow).Value = Z.Range("C3").Value
Y.Sheets("Data").Range("K" & lRow).Value = Z.Range("C4").Value
Y.Sheets("Data").Range("L" & lRow).Value = Z.Range("C6").Value
Dim LastRowF As Long
Dim LastRowG As Long
Dim LastRowH As Long
Dim LastRowI As Long
Dim LastRowJ As Long
LastRowF = ActiveSheet.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowG = ActiveSheet.Range("I:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowH = ActiveSheet.Range("J:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowI = ActiveSheet.Range("K:K").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowJ = ActiveSheet.Range("L:L").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
CopyrangeG = "I" & LastRowG & ":" & "I" & LastRowF
CopyrangeH = "J" & LastRowH & ":" & "J" & LastRowF
CopyrangeI = "K" & LastRowI & ":" & "K" & LastRowF
CopyrangeJ = "L" & LastRowJ & ":" & "L" & LastRowF
If nT2 > 1 Then
ActiveSheet.Range(CopyrangeG).FillDown
ActiveSheet.Range(CopyrangeH).FillDown
ActiveSheet.Range(CopyrangeI).FillDown
ActiveSheet.Range(CopyrangeJ).FillDown
End If
'Afdelingspecifiek(T3)
lRow = Y.Worksheets("Data").Cells(Y.Worksheets("Data").Rows.Count, 1).End(xlUp).Row
lRow = lRow + 1
T3.Copy
Y.Worksheets("Data").Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Y.Sheets("Data").Range("I" & lRow).Value = "Afdelingspecifiek"
Y.Sheets("Data").Range("J" & lRow).Value = Z.Range("C3").Value
Y.Sheets("Data").Range("K" & lRow).Value = Z.Range("C4").Value
Y.Sheets("Data").Range("L" & lRow).Value = Z.Range("C6").Value
Dim LastRowK As Long
Dim LastRowL As Long
Dim LastRowM As Long
Dim LastRowN As Long
Dim LastRowO As Long
LastRowK = ActiveSheet.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowL = ActiveSheet.Range("I:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowM = ActiveSheet.Range("J:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowN = ActiveSheet.Range("K:K").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowO = ActiveSheet.Range("L:L").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
CopyrangeL = "I" & LastRowL & ":" & "I" & LastRowK
CopyrangeM = "J" & LastRowM & ":" & "J" & LastRowK
CopyrangeN = "K" & LastRowN & ":" & "K" & LastRowK
CopyrangeO = "L" & LastRowO & ":" & "L" & LastRowK
If nT3 > 1 Then
ActiveSheet.Range(CopyrangeL).FillDown
ActiveSheet.Range(CopyrangeM).FillDown
ActiveSheet.Range(CopyrangeN).FillDown
ActiveSheet.Range(CopyrangeO).FillDown
End If
'Individueel (T4)
lRow = Y.Worksheets("Data").Cells(Y.Worksheets("Data").Rows.Count, 1).End(xlUp).Row
lRow = lRow + 1
T4.Copy
Y.Worksheets("Data").Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
Y.Sheets("Data").Range("I" & lRow).Value = "Individueel"
Y.Sheets("Data").Range("J" & lRow).Value = Z.Range("C3").Value
Y.Sheets("Data").Range("K" & lRow).Value = Z.Range("C4").Value
Y.Sheets("Data").Range("L" & lRow).Value = Z.Range("C6").Value
Application.CutCopyMode = False
Dim LastRowP As Long
Dim LastRowQ As Long
Dim LastRowR As Long
Dim LastRowS As Long
Dim LastRowT As Long
LastRowP = ActiveSheet.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowQ = ActiveSheet.Range("I:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowR = ActiveSheet.Range("J:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowS = ActiveSheet.Range("K:K").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowT = ActiveSheet.Range("L:L").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowU = ActiveSheet.Range("N:N").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
CopyrangeQ = "I" & LastRowQ & ":" & "I" & LastRowP
CopyrangeR = "J" & LastRowR & ":" & "J" & LastRowP
CopyrangeS = "K" & LastRowS & ":" & "K" & LastRowP
CopyrangeT = "L" & LastRowT & ":" & "L" & LastRowP
'Formule in Kolom M
CopyrangeU = "N" & LastRowU & ":" & "N" & LastRowP
If nT4 > 1 Then
ActiveSheet.Range(CopyrangeQ).FillDown
ActiveSheet.Range(CopyrangeR).FillDown
ActiveSheet.Range(CopyrangeS).FillDown
ActiveSheet.Range(CopyrangeT).FillDown
ActiveSheet.Range(CopyrangeU).FillDown
End If
' Y.Close (True)
'Quote weghalen bij opleveren
'Sheets("Variabelen").Range("H2").Value = Sheets("Variabelen").Range("H2").Value + 1
Else
MsgBox ("Niet nog een keer Sylvia!!!!")
End If
Else
'Do nothing
End If
End Sub
None

Related

How to copy and find the last 125 row?

I have a task where I need to get the last 125 data from an excel workbook copied to another workbook. And I want the user to select from a file browser the excel file where the data has been stored. The data will always in the the range of C17:C2051, F17:F2051 and goes on...
At last I want to put two formula above these ranges.
There are the formulas:
=AVARAGE(INDEX(C17:C2051;MATCH(MAX(C17:C2051);C17:C2051;1)):INDEX(C17:C2051;MAX(1;MATCH(MAX(C17:C2051);C17:C2051;1)-124)))
=STDEV(INDEX(C17:C2051;MATCH(MAX(C17:C2051);C17:C2051;1)):INDEX(C17:C2051;MAX(1;MATCH(MAX(C17:C2051);C17:C2051;1)-124)))
I wrote some code but right now it's actually doing nothing.
Sub Get_Data_From_File()
Dim FileToOpen As String
Dim File As Workbook
FileToOpen = Application.GetOpenFilename("Excel files (*.xlsx), *.xlsx")
Dim LastRow As Long
Dim Last8Rows As Range
LastRow = File.Range("D" & File.Rows.Count).End(xlUp).Row
Set Last8Rows = File.Range("C" & LastRow - 7)
Last8Rows.Copy
End Sub
This should get you started:
Sub Get_Data_From_File()
Const START_ROW As Long = 17
Const NUM_ROWS As Long = 125
Dim FileToOpen As String
Dim wb As Workbook, ws As Worksheet, wsDest As Worksheet
Dim LastRow As Long, FirstRow As Long
Dim LastRows As Range
FileToOpen = Application.GetOpenFilename("Excel files (*.xlsx), *.xlsx", _
Title:="Select file to import from")
If FileToOpen = False Then Exit Sub 'no file selected
Set wsDest = ActiveSheet 'pasting here; or specfy some other sheet...
Set wb = Workbooks.Open(FileToOpen, ReadOnly:=True)
Set ws = wb.Worksheets("data") 'or whatever sheet you need
LastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row 'find last row
If LastRow < START_ROW Then LastRow = START_ROW
FirstRow = IIf(LastRow - NUM_ROWS >= START_ROW, LastRow - NUM_ROWS, START_ROW) 'find first row
'copy ranges
ws.Range("C" & FirstRow & ":C" & LastRow).Copy wsDest.Cells(START_ROW, "C")
ws.Range("F" & FirstRow & ":F" & LastRow).Copy wsDest.Cells(START_ROW, "F")
'Add the formulas (note you need the US-format when using .Formula
' or you can use your local format with .FormulaLocal
wb.Close False 'no save
End Sub
After all these days it's working finally. I modified some lines in the code and it's doing the job. Thanks again #TimWilliams!
Here's my solution:
Sub Get_Data_From_File()
Const START_ROW As Long = 17
Const NUM_ROWS As Long = 124
Dim FileToOpen As String
Dim wb As Workbook, ws As Worksheet, wsDest As Worksheet
Dim LastRow As Long, FirstRow As Long
Dim LastRows As Range
FileToOpen = Application.GetOpenFilename("Excel files (*.xlsx), *.xlsx", _
Title:="Select file to import from") 'no file selected
Set wsDest = ActiveSheet 'pasting here; or specfy some other sheet...
Set wb = Workbooks.Open(FileToOpen, ReadOnly:=True)
Set ws = wb.Worksheets("SMI_650_Lxy") 'or whatever sheet you need
LastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row 'find last row
If LastRow < START_ROW Then LastRow = START_ROW
FirstRow = IIf(LastRow - NUM_ROWS >= START_ROW, LastRow - NUM_ROWS, START_ROW) 'find first row
Debug.Print "FirstRow" & vbTab & FirstRow 'test
Debug.Print "LastRow" & vbTab & LastRow
Debug.Print "START_ROW" & vbTab & START_ROW
'copy ranges
ws.Range("C" & FirstRow & ":C" & LastRow).Copy wsDest.Cells(START_ROW, "C")
ws.Range("F" & FirstRow & ":F" & LastRow).Copy wsDest.Cells(START_ROW, "F")
ws.Range("M" & FirstRow & ":M" & LastRow).Copy wsDest.Cells(START_ROW, "M") 'formula
ws.Range("P" & FirstRow & ":P" & LastRow).Copy wsDest.Cells(START_ROW, "P")
ws.Range("S" & FirstRow & ":S" & LastRow).Copy wsDest.Cells(START_ROW, "S")
ws.Range("V" & FirstRow & ":V" & LastRow).Copy wsDest.Cells(START_ROW, "V")
ws.Range("Y" & FirstRow & ":Y" & LastRow).Copy wsDest.Cells(START_ROW, "Y")
ws.Range("AF" & FirstRow & ":AF" & LastRow).Copy wsDest.Cells(START_ROW, "AF") 'formula
ws.Range("AM" & FirstRow & ":AM" & LastRow).Copy wsDest.Cells(START_ROW, "AM") 'formula
ws.Range("AP" & FirstRow & ":AP" & LastRow).Copy wsDest.Cells(START_ROW, "AP")
ws.Range("AS" & FirstRow & ":AS" & LastRow).Copy wsDest.Cells(START_ROW, "AS")
ws.Range("AV" & FirstRow & ":AV" & LastRow).Copy wsDest.Cells(START_ROW, "AV")
ws.Range("AY" & FirstRow & ":AY" & LastRow).Copy wsDest.Cells(START_ROW, "AY")
ws.Range("BB" & FirstRow & ":BB" & LastRow).Copy wsDest.Cells(START_ROW, "BB")
ws.Range("BE" & FirstRow & ":BE" & LastRow).Copy wsDest.Cells(START_ROW, "BE")
ws.Range("BL" & FirstRow & ":BL" & LastRow).Copy wsDest.Cells(START_ROW, "BL") 'formula
ws.Range("BS" & FirstRow & ":BS" & LastRow).Copy wsDest.Cells(START_ROW, "BS") 'formula
ws.Range("BV" & FirstRow & ":BV" & LastRow).Copy wsDest.Cells(START_ROW, "BV")
ws.Range("BZ" & FirstRow & ":BZ" & LastRow).Copy wsDest.Cells(START_ROW, "BZ")
ws.Range("CD" & FirstRow & ":CD" & LastRow).Copy wsDest.Cells(START_ROW, "CD")
ws.Range("CH" & FirstRow & ":CH" & LastRow).Copy wsDest.Cells(START_ROW, "CH")
ws.Range("CK" & FirstRow & ":CK" & LastRow).Copy wsDest.Cells(START_ROW, "CK")
ws.Range("CN" & FirstRow & ":CN" & LastRow).Copy wsDest.Cells(START_ROW, "CN")
ws.Range("CQ" & FirstRow & ":CQ" & LastRow).Copy wsDest.Cells(START_ROW, "CQ")
ws.Range("CT" & FirstRow & ":CT" & LastRow).Copy wsDest.Cells(START_ROW, "CT")
ws.Range("CW" & FirstRow & ":CW" & LastRow).Copy wsDest.Cells(START_ROW, "CW")
ws.Range("CZ" & FirstRow & ":CZ" & LastRow).Copy wsDest.Cells(START_ROW, "CZ")
ws.Range("DC" & FirstRow & ":DC" & LastRow).Copy wsDest.Cells(START_ROW, "DC")
ws.Range("DF" & FirstRow & ":DF" & LastRow).Copy wsDest.Cells(START_ROW, "DF")
'Add the formulas (note you need the US-format when using .Formula
' or you can use your local format with .FormulaLocal
wb.Close False 'no save
End Sub

how to create multiple charts with vba

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

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 to speed up this looping code?

Can you anyone offer assistance on speeding up this code? I am assume an array can be used, but I am terrible using them. Is there another way? Thanks so much!
Application.ScreenUpdating = False
'IF using Indexed Values
If Sheets("interface").Range("C24") = "Y" Then
Dim x As Integer
Dim i As Long
For x = 15 To 51
LastRow = Sheets("db_main").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Sheets("db_main").Range("S" & i) = True And Sheets("db_main").Range("C" & i) = Sheets("interface").Range("F" & x) Then
Sheets("db_main").Range("C" & i).Copy
Sheets("intersource").Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("db_main").Range("A" & i).Copy
Sheets("intersource").Range("B" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("db_main").Range("H" & i).Copy
Sheets("intersource").Range("C" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("db_main").Range("D" & i).Copy
Sheets("intersource").Range("D" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("db_main").Range("M" & i).Copy
Sheets("intersource").Range("E" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("db_main").Range("O" & i).Copy
Sheets("intersource").Range("F" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
End If
Next i
Next x
End If
If you'd like to avoid using arrays, you could try eliminating the copy/paste in favor of just assigning values (which should improve the performance). Try this out:
'IF using Indexed Values
Application.ScreenUpdating = False
If Sheets("interface").Range("C24") = "Y" Then
Dim x As Long, i As Long, LastRow As Long, _
LastSourceRow As Long, Counter As Long
Dim DBSheet As Worksheet, SourceSheet As Worksheet, _
InterSheet As Worksheet
'identify worksheets for easier reference
Set DBSheet = ThisWorkbook.Worksheets("db_main")
Set SourceSheet = ThisWorkbook.Worksheets("intersource")
Set InterSheet = ThisWorkbook.Worksheets("interface")
For x = 15 To 51
'identify last rows
LastRow = DBSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastSourceRow = SourceSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Counter = 1
For i = 2 To LastRow
If DBSheet.Range("S" & i) = True And DBSheet.Range("C" & i) = InterSheet.Range("F" & x) Then
'write DB column C to Source column A
SourceSheet.Cells(LastSourceRow + Counter, 1) = _
DBSheet.Cells(i, 3).Value
'write DB column A to Source column B
SourceSheet.Cells(LastSourceRow + Counter, 2) = _
DBSheet.Cells(i, 1).Value
'write DB column H to Source column C
SourceSheet.Cells(LastSourceRow + Counter, 3) = _
DBSheet.Cells(i, 8).Value
'write DB column D to source column D
SourceSheet.Cells(LastSourceRow + Counter, 4) = _
DBSheet.Cells(i, 4).Value
'write DB column M to Source column E
SourceSheet.Cells(LastSourceRow + Counter, 5) = _
DBSheet.Cells(i, 13).Value
'write DB column O to Source column F
SourceSheet.Cells(LastSourceRow + Counter, 6) = _
DBSheet.Cells(i, 15).Value
'increment counter
Counter = Counter + 1
End If
Next i
Next x
End If
Application.ScreenUpdating = True

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