VBA Macro is ignoring nextBlankRow and duplicates - excel

What I want the Macro to accomplish:
I want the user to be able to fill in data from E2 to E9 on the spreadsheet. When the user presses the "Add Car" button the macro is supposed to be executed. The makro then should take the handwritten data, copy everything from E2:E9 and put it into a table that starts at with C13 and spans over 7 columns, always putting the new set of data in the next free row. It is also supposed to check for duplicates and give an alert while not overwriting the original set of data
So my problem is, that I want the Macro I'm writing to take the information put into certain cells and then copy them into a table underneath.
I'm starting the Macro like this
Sub addData()
Dim lastrow As Long, nextBlankRow As Long
lastrow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlPrevious, _
MatchCase:=False).Row
nextBlankRow = lastrow + 1
Here I try to define how the Macro is supposed to find the last empty cell and also define lastrow and nextBlankRow.
After that I'm starting with a simple If statement to see if the person has at least something in E2 on the same sheet.
If Range("E2") = "" Then
MsgBox "Wählen Sie ein KFZ aus!"
Range("E2").Select
Exit Sub
End If
This works. When I'm not putting something into E2 I get the textbox with the alert.
Anyway if the IF-Statement is not triggered to exit the sub the Macro is given the instructions to get the information and put it in the table below
Cells(nextBlankRow, 3) = Range("E2")
Cells(nextBlankRow, 4) = Range("E3")
Cells(nextBlankRow, 5) = Range("E4")
Cells(nextBlankRow, 6) = Range("E5")
Cells(nextBlankRow, 7) = Range("E6")
Cells(nextBlankRow, 8) = Range("E7")
Cells(nextBlankRow, 9) = Range("E8")
Here seems to be a problem that probably relates to me failing to define variables correctly?
Because the Macro finds the right row but only overwrites into that row. So it ignores the fact that it "should" skip to the nextBlankrow which I defined earlier as
nextBlankRow = lastrow + 1
In addition to that I also have a line of code inplace which is supposed to check for duplicates
Dim p As Long, q As Long
p = 13
q = p + 1
Do While Cells(p, 3) <> ""
Do While Cells(q, 3) <> ""
If Cells(p, 3) = Cells(q, 3) And Cells(p, 4) = Cells(q, 4) Then
MsgBox "Datensatz schon vorhanden!"
Range(Cells(q, 3), Cells(q, 9)).ClearContents
Else
q = q + 1
End If
Loop
p = p + 1
q = p + 1
Loop
End Sub
Which always gives a false return. So even if the same set of Data is copied twice into the same row (as it does) it only "refreshes" the data and doesn't say "you're not allowed to do that".
I'm at a loss here.
Here's the full code for ease of use
Sub addData()
Dim lastrow As Long, nextBlankRow As Long
lastrow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlPrevious, _
MatchCase:=False).Row
nextBlankRow = lastrow + 1
If Range("E2") = "" Then
MsgBox "Wählen Sie ein KFZ aus!"
Range("E2").Select
Exit Sub
End If
Cells(nextBlankRow, 3) = Range("E2")
Cells(nextBlankRow, 4) = Range("E3")
Cells(nextBlankRow, 5) = Range("E4")
Cells(nextBlankRow, 6) = Range("E5")
Cells(nextBlankRow, 7) = Range("E6")
Cells(nextBlankRow, 8) = Range("E7")
Cells(nextBlankRow, 9) = Range("E8")
Dim p As Long, q As Long
p = 13
q = p + 1
Do While Cells(p, 3) <> ""
Do While Cells(q, 3) <> ""
If Cells(p, 3) = Cells(q, 3) And Cells(p, 4) = Cells(q, 4) Then
MsgBox "Datensatz schon vorhanden!"
Range(Cells(q, 3), Cells(q, 9)).ClearContents
Else
q = q + 1
End If
Loop
p = p + 1
q = p + 1
Loop
End Sub
```![enter image description here](https://i.stack.imgur.com/dJozM.jpg)![enter image description here](https://i.stack.imgur.com/Q90Ah.jpg)

Please, test the next code:
Sub copyRangeOnLastEmptyRow()
Dim sh As Worksheet, arr, lastERow As Long, matchCel As Range
Set sh = ActiveSheet
arr = sh.Range("E2:E9").value
lastERow = sh.Range("C" & sh.rows.Count).End(xlUp).row + 1
If lastERow < 13 Then lastERow = 13
'check if the range has not been alredy copied:
Set matchCel = sh.Range("C13:C" & lastERow - 1).Find(WHAT:=sh.Range("E2").value, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
If Not matchCel Is Nothing Then
MsgBox sh.Range("E2").value & " has been found in cell " & matchCel.Address & "."
'bring up the data of the existing row:
sh.Range("E3:E9").value = Application.Transpose(sh.Range(matchCel.Offset(0, 1), matchCel.Offset(0, 7)).value)
Exit Sub
End If
sh.Range("C" & lastERow).Resize(1, UBound(arr)).value = Application.Transpose(arr)
sh.Range("E2:E9").ClearContents
End Sub

Related

speed up Excel vba program

Kindly see below code where it takes too much time run for more than 30rows in a range. (its similar to knapsack algorithm requirements)
let me try to explain below in detail,
Input Base sheet: Column A having values (For ex: 1555),
Column B having its Assignment value (A1),
Column C & D its filter value which will perform against input data sheet file.
Program working concept:
it takes first row(2) data from base sheet and apply filter (C2 & D2 value) in input data sheet (Column A & B respectively) then it checks value in column C and it find best sum to match the value (1555) or nearest to it and after it assigns value (which is A1) against those rows and repeats the same for next rows.
I have posted image below.
Kindly refer for Input Base sheet and Input Data sheet and
copy the codes in another workbook.
Run the macro, Choose Base sheet and the Data sheet. Program would run and assigns in Input data sheet. It runs super fast in lesser rows when I have more rows it gets hang/takes too hours to run.
Help me to where it can be speed up.
Appreciate your supports.
Thanks
input base sheet
input data sheet:
Sub sample1()
Dim lrow As Integer
Dim frow As Integer
Dim row As Integer
Dim ar As Variant
Dim aar As Variant
Dim Sol(), csol()
Dim arr As Variant
Dim pos As Integer
Dim arow() As Integer
Dim rng As Range
Dim rn As Range
Dim r As Range
Dim k As Integer
Dim itr As Integer
Dim path As String
Dim tm_base As Workbook
Dim tm_data As Workbook
Dim sh_base As Worksheet
Dim sh_data As Worksheet
Dim sh As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set sh = ActiveSheet
ReDim arr(0)
arr(0) = ""
path = FileSelection("Input Base")
If path = "" Then Exit Sub
Set tm_base = Workbooks.Open(path)
path = FileSelection("Input Data")
If path = "" Then Exit Sub
Set tm_data = Workbooks.Open(path)
Set sh_base = tm_base.ActiveSheet
Set sh_data = tm_data.ActiveSheet
lrow = sh_data.Cells(Rows.Count, "A").End(xlUp).row
frow = sh_base.Cells(Rows.Count, "A").End(xlUp).row
SortMacro ActiveSheet, sh_base.Range("A2:A" & frow), sh_base.Range("A1:G" & frow), 2
SortMacro ActiveSheet, sh_data.Range("C2:C" & lrow), sh_data.Range("A1:G" & lrow), 2
For row = 2 To frow
If sh_base.Cells(row, "H") <> "Done" Then
itr = 1
sh_data.Range("A1:G" & lrow).AutoFilter Field:=4, Criteria1:="="
op2:
sh_data.Range("A1:G" & lrow).AutoFilter Field:=1, Criteria1:=sh_base.Cells(row, "C").Value
sh_data.Range("A1:G" & lrow).AutoFilter Field:=2, Criteria1:=sh_base.Cells(row, "D").Value
Set rn = Nothing
On Error Resume Next
Set rn = sh_data.Range("C2:C" & lrow).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rn Is Nothing Then
ReDim ar(0)
ReDim arow(0)
k = 1
For Each r In rn
ReDim Preserve arow(k)
ReDim Preserve ar(k)
ar(k) = r.Value
arow(k) = r.row
k = k + 1
Next
ReDim Sol(LBound(ar) To UBound(ar))
ReDim csol(LBound(ar) To UBound(ar))
limsum = sh_base.Cells(row, "A").Value
For i = LBound(ar) To UBound(ar)
If ar(i) > limsum Then
ar(i) = -1
End If
Next
maxsum = 0
findsum ar, Sol, csol, maxsum, limsum, UBound(ar), UBound(ar)
ss = ""
For i = 1 To Sol(0)
'ss = ss & sep & ar(sol(i))
'sep = ","
If Not arr(UBound(arr)) = "" Then
ReDim Preserve arr(UBound(arr) + 1)
End If
arr(UBound(arr)) = ar(Sol(i))
Next i
'MsgBox ss & " sum =" & maxsum
For j = LBound(arr) To UBound(arr)
pos = Application.Match(arr(j), ar, False)
If ar(pos - 1) > 0 Then
ar(pos - 1) = -1
End If
pos = arow(pos - 1)
If sh.Range("B1") = "Option 01" Then
sh_data.Cells(pos, "D") = sh_base.Cells(row, "B").Value
Else
sh_data.Cells(pos, "D") = sh_base.Cells(row, "B").Value & " " & Format(itr, "00")
End If
Next
ReDim arr(0)
arr(0) = ""
sh_base.Cells(row, "H") = "Done"
If sh.Range("B1") = "Option 02" Then
sh_data.Range("A1:G" & lrow).AutoFilter Field:=4, Criteria1:="="
Set rng = sh_data.Range("A1:A" & lrow).SpecialCells(xlCellTypeVisible)
If rng.Cells.Count > 1 Then
itr = itr + 1
GoTo op2
End If
End If
End If
sh_data.Range("A1:G" & frow).AutoFilter Field:=1
sh_data.Range("A1:G" & frow).AutoFilter Field:=2
sh_data.Range("A1:G" & lrow).AutoFilter Field:=4
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub findsum(ByVal a, ByRef Sol, ByRef csol, ByRef maxsum, ByRef limsum, si, maxcount, Optional s = 0, Optional lvl = 1, Optional dif = 100000, Optional minuscount = 0, Optional tsol, Optional j = 0)
' recursive sub
For i = LBound(a) To si
If a(i) > 0 Then
If s + a(i) > limsum Then findsum a, Sol, csol, maxsum, limsum, i - 1, maxcount, s, lvl + 1, dif, minuscount, tsol
s = s + a(i)
csol(lvl) = i
If s <= limsum Then
If s > maxsum Then ' we found a sum greater than current max we save it
maxsum = s
Sol(0) = lvl
For j = 1 To lvl
Sol(j) = csol(j)
Next j
End If
If i > LBound(a) Then ' pick another number
findsum a, Sol, csol, maxsum, limsum, i - 1, maxcount, s, lvl + 1, dif, minuscount, tsol
End If
End If
s = s - a(i)
If maxsum = limsum Then Exit For 'exit if exact match
End If
Next i
End Sub
Sub SortMacro(ws As Worksheet, rn As Range, rng As Range, ord As Integer)
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add Key:=rn, _
SortOn:=xlSortOnValues, Order:=ord, DataOption:=xlSortNormal
With ws.Sort
.SetRange rng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Function FileSelection(file As String)
Dim path As String
Dim st As String
Dim i As Integer
Dim j As Integer
FileSelection = ""
With Application.FileDialog(3)
.title = "Select the " & file & " file"
.AllowMultiSelect = False
.InitialFileName = st
.Show
If .SelectedItems.Count = 0 Then
MsgBox "You didn't select the file!", vbExclamation, "Canceled"
Exit Function
Else
FileSelection = .SelectedItems(1)
End If
End With
End Function
You can't. I ran it. With 20 base data points and 100 data points you already have sub findsum called 79 million times. It's a combinatorial explosion and no amount of code tweaking will fix that. You'll have to find a better algorithm.

controlling excel cells and writing it to other cells

I have a excel sheet like at below. I want to find some strings in my excel's third cell. The string is 180 days. When the cell value includes 180 days, I want write previous cells value in next to empty cells like in below picture. I want to write process plan in first cell, operation title in second cell. I wrote this codes but it's not working like what I want.
Sub Button1_Click()
Dim excelRange As Long
Dim i As Long
Dim k As Long
'Dim txt As String
excelRange = ActiveSheet.Cells(1048576, 3).End(xlUp).Row
k = 2
For a = 2 To excelRange
txt = Cells(a, 3)
k = a
If InStr(1, txt, "180 days") > 0 Then
For i = a To 2 Step -1
txt1 = Cells(i, 3)
If InStr(1, txt1, "Oper Title") > 0 Then
Cells(a, 2) = Cells((k + 1), 3)
ElseIf InStr(1, txt1, "Process") > 0 Then
Cells(a, 1) = Cells(k, 3)
Else:
k = k - 1
End If
Next i
End If
Next a
End Sub
Sub test()
Dim excelRange As Range
Dim criteriRange As Range
Dim evaluateRange As Range
Dim c As Range
Dim i As Long
Set excelRange = Range("C1:C" & Cells(1048576, 3).End(xlUp).Row)
For Each cell In excelRange
If UCase(cell.Text) Like "*180 DAY*" Then
If criteriRange Is Nothing Then
Set criteriRange = cell
Else
Set criteriRange = Union(criteriRange, cell)
End If
End If
Next
If Not criteriRange Is Nothing Then
For Each c In criteriRange
For i = c.Row To 1 Step -1
If UCase(Cells(i, 3)) Like "*PROCESS PLAN*" Then
c.Offset(0, -2) = Cells(i, 3)
Exit For
End If
Next
For i = c.Row To 1 Step -1
If UCase(Cells(i, 3)) Like "*OPER TITLE*" Then
c.Offset(0, -1) = Cells(i + 1, 3)
Exit For
End If
Next
Next
End If
End Sub
Instead of looping through a range, your macro will run much faster if you use the Range.Find method.
In your code, you did not check to ensure that all of your sets of Process | Title | 180 Days are complete. I added that to the code below, by making sure that the Process and Title rows were found after the previous 180 day row (or before the 180 day row for the first instance).
In your code, you did not check to see if the cells where you want to output this information are, in fact, empty. If you really want to do that, you can easily modify this code to check these cells before writing to them.
Hopefully, through the comments and the use of meaningful variable names, you will be able to understand what is going on. But you might want to also read through VBA Help for the Range.Find method.
In general, we search down to find the 180 day row, then search up from there to find the associated Process and Title rows.
If a preceding Process or Title row should be before the preceding 180 day row, then we have an incomplete set, output the error message, and terminate the procedure.
If necessary, you could develop procedures to deal with incomplete data sets.
Option Explicit
Sub Info()
Dim searchRng As Range, C As Range, cProcessPlan As Range, cOperTitle As Range
Dim firstAddress As String 'to check when we are done
Dim lastAddress As String 'to check for incomplete data sets
'Where are we looking?
Set searchRng = ThisWorkbook.Worksheets("Sheet1").Columns(3)
With searchRng
Set C = .Find(what:="180 Days", after:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlPart, searchorder:=xlByRows, _
searchdirection:=xlNext, MatchCase:=False)
If Not C Is Nothing Then
firstAddress = C.Address
lastAddress = C.Address
Set cOperTitle = .Find(what:="Oper Title", after:=C, searchdirection:=xlPrevious)
Set cProcessPlan = .Find(what:="Process Plan", after:=C, searchdirection:=xlPrevious)
If Not cOperTitle Is Nothing Or Not cProcessPlan Is Nothing Then
'check for full set
If cOperTitle.Row > Range(lastAddress).Row Or cProcessPlan.Row > Range(lastAddress).Row Then
MsgBox "Incomplete Data Set" & vbLf & "Before: " & C.Address
Exit Sub
End If
C.Offset(0, -1) = cOperTitle.Offset(1, 0)
C.Offset(0, -2) = cProcessPlan
Else
MsgBox "Title or Process Plan not found"
Exit Sub
End If
Do
Set C = .Find(what:="180 Days", after:=C, LookIn:=xlValues, _
lookat:=xlPart, searchorder:=xlByRows, _
searchdirection:=xlNext, MatchCase:=False)
If C.Address = firstAddress Then Exit Do
Set cOperTitle = .Find(what:="Oper Title", after:=C, searchdirection:=xlPrevious)
Set cProcessPlan = .Find(what:="Process Plan", after:=C, searchdirection:=xlPrevious)
'check for a full set
If cOperTitle.Row < Range(lastAddress).Row Or cProcessPlan.Row < Range(lastAddress).Row Then
MsgBox "Incomplete Data Set" & vbLf & "Between: " & lastAddress & " and " & C.Address
Exit Sub
End If
C.Offset(0, -1) = cOperTitle.Offset(1, 0)
C.Offset(0, -2) = cProcessPlan
lastAddress = C.Address
Loop
End If
End With
'next stuff
End Sub
Using a variant array is fast.
Sub test()
Dim Ws As Worksheet
Dim rngDB As Range
Dim vDB As Variant
Dim vRow(), vTitle(), vProcess()
Dim i As Long, j As Long, k As Long, m As Long
Set Ws = ActiveSheet
With Ws
Set rngDB = .Range("a1", .Range("c" & Rows.Count).End(xlUp))
End With
vDB = rngDB
For i = 1 To UBound(vDB, 1)
If InStr(vDB(i, 3), "180 days") Then
j = j + 1
ReDim Preserve vRow(1 To j)
vRow(j) = i
ElseIf InStr(vDB(i, 3), "Oper Title") Then
k = k + 1
ReDim Preserve vTitle(1 To k)
vTitle(k) = vDB(i + 1, 3)
ElseIf InStr(vDB(i, 3), "Process") Then
m = m + 1
ReDim Preserve vProcess(1 To m)
vProcess(m) = vDB(i, 3)
End If
Next i
For i = 1 To j
vDB(vRow(i), 1) = vProcess(i)
vDB(vRow(i), 2) = vTitle(i)
Next i
rngDB = vDB
End Sub

Loop not going further

I'm pretty new to VBA and programming in general.
This is what I'm trying to do:
I have a database starting on row 21 of my worksheet (storing a name, second name, job). I'm trying to use a for loop, to create a new worksheet for every name in the database - for example (1 - William), (2 - John) ...
When we add a new member to our database and run our macro - It should add the a new sheet (but don't change anything to the existing ones), so with other words just skip (1 - William) and (2 - John) but adds (3 - Kera).
So far it's creating the 2 first worksheets, but when I add someone to my database - the new worksheet isn't added.
Could any of you experts help me with this issue, and brake down what I'm doing wrong?
Sub test()
Dim i As Long, LastRow As Long
LastRow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Dim blnFound As Boolean
blnFound = False
For i = 21 To LastRow
For x = 1 To Worksheets.Count
If Worksheets(x).Name = ((i -21) + 1) & " - " & Worksheets("Database").Cells(i, 3).Value Then
blnFound = True
End If
Next
If blnFound = False Then
Worksheets.Add.Move After:=Sheets(1)
ActiveSheet.Name = ((i - 21) + 1) & " - " & Worksheets("Database").Cells(i, 3).Value
End If
Next i
End Sub
I hope you this will help you:
Sub CreateNewSheetFromRange()
Dim mySht As Worksheet
Dim mySheet As Worksheet
Dim BeginRow As Long
Dim myStr As String
Dim r As New Collection
Dim Pos As Integer
On Error Resume Next
For a = 1 To Sheets.Count
'To List Your Sheet With Name Begin With Number & " - "
'If you don't care how many time time the same value repeat,
'you can disobey this for loop
Pos = InStr(Sheets(a).Name, " - ")
If Pos > 0 Then
r.Add Sheets(a).Name, Mid(Sheets(a).Name, Pos + 3)
End If
On Error GoTo 0
Next
BeginRow = 21
Do While True
On Error Resume Next
myStr = ((BeginRow - 21) + 1) & " - " & Worksheets("Data").Cells(BeginRow, 3).Value
If Worksheets("Data").Cells(BeginRow, 3).Value = "" Then
Exit Do
End If
'If you hope avoid your repeated cells value to create new sheet
'perform this
myVal = r.Item(Worksheets("Data").Cells(BeginRow, 3).Value)
'If you don't care about repeated value, you change this with:
'set mySht=worksheets(myStr)
If Err.Description <> "" Then
On Error GoTo 0
Set mySheet = Sheets.Add(After:=Sheets(Sheets.Count))
'If you don't care about repeated value, remove this r.add
r.Add myStr, Worksheets("Data").Cells(BeginRow, 3).Value
mySheet.Name = myStr
a = 1
End If
BeginRow = BeginRow + 1
Loop
End Sub

runtime error 1004 : excel VBA

I keep getting runtime error 1004, on the following line:
originBook.Sheets(1).Range(Cells(1, 1), Cells(lastRow, lastCol)).Copy
Here's the full code
Sub Obtain_Source()
Application.DisplayAlerts = False
Dim theOrigin, theString, newCol As String
Dim lastRow, lastCol As Long
Dim theRange As Range
Dim originBook, originBookBackup, macroBook As Workbook
Dim originOpen As Boolean
originOpen = False
Set macroBook = Workbooks("FY_Macro_Testt (DYNAMIC).xlsm")
theOrigin = Application.GetOpenFilename(fileFilter:="Excel Files (*.xls; *.xlsm; *.xlsx), *.xls' *.xlsm' *.xlsx", _
Title:="Fiscal Year Selection: Select Only One", ButtonText:="Open", MultiSelect:=False)
If TypeName(theOrigin) = "Boolean" Then
MsgBox "Don't just stand there. Do something." & vbNewLine & _
"Quit hitting CANCEL. >.< ", vbExclamation, "WARNING. CHOKING HAZARD."
Else
originOpen = True
Set originBook = Workbooks.Open(theOrigin)
lastRow = Range("A65536").End(xlUp).Row
lastCol = Range("XFD1").End(xlToLeft).Column
lastCol = originBook.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
originBook.Sheets(2).Visible = False
originBook.Sheets(3).Visible = False
originBook.Sheets(1).Range(Cells(1, 1), Cells(lastRow, lastCol)).Copy
macroBook.Sheets(1).Cells(6, 1).PasteSpecial
i = 1000
Do While 1000 <= 20000
j = i - 999
If originBook.Sheets(1).Cells(i, 1).Value <> vbNullString Or _
originBook.Sheets(1).Cells(i, 1).Value <> "" Then
originBook.Sheets(1).Range(Cells(j, 1), Cells(i - 1, lastCol)).Copy
macroBook.Sheets(1).Cells(j + 5, 1).PasteSpecial
End If
i = i + 1000
Loop
originBook.Sheets(2).Visible = True
originBook.Sheets(3).Visible = True
End If
If originOpen = True Then
originBook.Close
End If
End Sub
which one should I change?
Your error will almost certainly be because you are using
originBook.Sheets(1).Range(Cells(1, 1), Cells(lastRow, lastCol)).Copy
instead of, as #ShaiRado pointed out,
originBook.Sheets(1).Range(originBook.Sheets(1).Cells(1, 1), _
originBook.Sheets(1).Cells(lastRow, lastCol)).Copy
When they are not fully qualified, Cells references refer to cells on the ActiveSheet. Excel is therefore having to try to copy all the cells on Sheets(1) that lie in the area between two cells on the ActiveSheet. It's equivalent to saying "choose all the houses in Los Angeles that lie in the area between the intersection of E 79th St and 1st Avenue and the intersection of E 86th St and York Ave New York". (Not living in the USA, I hope that analogy makes sense.)

excel vba step thru rows faster

the code below works 100%. It scans for a match in Column B and copies and renames a group of cells when a match is found. However the is a line For lRow = Sheets("HR-Calc").Cells(Cells.Rows.count, "b").End(xlUp).Row To 7 Step -1
Where the step -1 will scan row by row from the bottom of the sheet until a match is found. It would be much easier if the step was set to End.(xlUp) instead of -1. searching every row is overkill because of how the data is set up End.(xlUp) would massive cut down the run time.
Is something like this possible?
Sub Fill_CB_Calc()
M_Start:
Application.ScreenUpdating = True
Sheets("summary").Activate
d_input = Application.InputBox("select first cell in data column", "Column Data Check", Default:="", Type:=8).Address(ReferenceStyle:=xlA1, RowAbsolute:=True, ColumnAbsolute:=False)
data_col = Left(d_input, InStr(2, d_input, "$") - 1)
data_row = Right(d_input, Len(d_input) - InStr(2, d_input, "$"))
Application.ScreenUpdating = False
Sheets("summary").Activate
Range(d_input).End(xlDown).Select
data_last = ActiveCell.Row
If IsEmpty(Range(data_col & data_row + 1)) = True Then
data_last = data_row
Else
End If
For j = data_row To data_last
CBtype = Sheets("summary").Range(data_col & j)
Sheets("HR-Calc").Activate
For lRow = Sheets("HR-Calc").Cells(Cells.Rows.count, "b").End(xlUp).Row To 7 Step -1
If Sheets("HR-Calc").Cells(lRow, "b") = CBtype Then
CBend = Sheets("HR-Calc").Range("C" & lRow).End(xlDown).Row + 1
Sheets("HR-Calc").Rows(lRow & ":" & CBend).Copy
CBstart = Sheets("HR-Calc").Range("c50000").End(xlUp).Row + 2
ActiveWindow.ScrollRow = CBstart - 8
Sheets("HR-Calc").Range("A" & CBstart).Insert Shift:=xlDown
CBold = Right(Range("c" & CBstart), Len(Range("C" & CBstart)) - 2)
box_name = Sheets("summary").Range(data_col & j).Offset(0, -10)
CBnew = Right(box_name, Len(box_name) - 2) & "-" ' <--this is custom and can be changed based on CB naming structure
If CBnew = "" Or vbCancel Then
End If
CBend2 = Range("c50000").End(xlUp).Row - 2
Range("C" & CBstart + 1 & ":" & "C" & CBend2).Select
Selection.Replace What:=CBold & "-", Replacement:=CBnew, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("C" & CBstart).FormulaR1C1 = "CB" & Left(CBnew, Len(CBnew) - 1)
GoTo M_Start2
Else
End If
Next lRow
M_Start2:
Next j
YN_result = MsgBox("Fill info for another block/inverter?", vbYesNo + vbExclamation)
If YN_result = vbYes Then GoTo M_Start
If YN_result = vbNo Then GoTo jumpout
jumpout:
' Sheets("summary").Range(d_input).Select
Application.ScreenUpdating = True
End Sub
I'm not sure if this will help but I've had a great performance increase with pulling the entire range you need to loop through into a variant array and then looping through the array. If I need to loop through large data sets, this method has worked out well.
Dim varArray as Variant
varArray = Range(....) 'set varArray to the range you're looping through
For y = 1 to uBound(varArray,1) 'loops through rows of the array
'code for each row here
'to loop through individual columns in that row, throw in another loop
For x = 1 to uBound(varArray, 2) 'loop through columns of array
'code here
Next x
Next y
You can also define the column indexes prior to executing the loop. Then you only need to execute the you need to pull those directly in the loop.
'prior to executing the loop, define the column index of what you need to look at
Dim colRevenue as Integer
colRevenue = 5 'or a find function that searches for a header named "Revenue"
Dim varArray as Variant
varArray = Range(....) 'set varArray to the range you're looping through
For y = 1 to uBound(varArray,1) 'loops through rows of the array
tmpRevenue = CDbl(varArray(y, colRevenue))
Next y
Hope this helps.
Look at doing a .find from the bottom up.
Perform a FIND, within vba, from the bottom of a range up
That will eliminate the need to do the for loop from the last row to the first occurrence of the value you want to locate.

Resources