Help With Code to store Macro In Personal.xls file

[JGARDNER-AIT]

Hello - Thanks to "GTO" for gettng me this code. I cant get ahold of him to make a change so I am asking the group to see if they can help me modify how this code is stored to be useful in future sheets.

Process:
This data is exported from Access into excel. It always deletes the master sheet and all of its macros and imports in the new data. the problem is, the macro keeps getting deleted. I would like to store this macro in my personal.xls file, but when I do, it wont work on the exported sheet. I think it has to do with the way "GTO" wrote the code. I'm not a expert, can some help?

Thanks in advance.



Option Explicit
Sub CalcShorts_2()
Dim _
wks As Worksheet, _
rngPartNo As Range, _
rCell As Range, _
aryPartNos As Variant, _
i As Long, _
lFirstRecordRow As Long, _
lLastRecordRow As Long, _
lRow As Long, _
lRowInner As Long, _
bolExit As Boolean

'// Alter sheetname to suit //
Set wks = ThisWorkbook.Worksheets("ExampleSheet")

'// Set a reference to the range from A1 to the last cell in Col A that has a val in//
'// it, by using the RangeFound() function. //
Set rngPartNo = Range(wks.Cells(1, "A"), RangeFound(wks.Range("A:A")))

Application.ScreenUpdating = False

'// After this line, everything starting with a dot belongs to rngPartNo. //
With rngPartNo

'// Filter our part numbers in Col A, so that ea part no is just listed once //
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True

'// Initially size our array to one empty element. We will then bump the base //
'// up to one in the first loop, as an easy way to build the array and //
'// keeping it correctly sized. //
ReDim aryPartNos(0 To 0)

'// Basically, we want to resize and offset from our original range to leave the//
'// header label out, then return only the visible cells to loop thru, so we //
'// just looping once per part no. //
For Each rCell In .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
'// Build our array of part numbers. //
ReDim Preserve aryPartNos(1 To UBound(aryPartNos) + 1)
aryPartNos(UBound(aryPartNos)) = rCell.Value
Next

'// Ditch the filter//
.Parent.ShowAllData

'// Looping thru our array of part numbers //
For i = LBound(aryPartNos) To UBound(aryPartNos)

'// ...filter upon the part number. //
.AutoFilter Field:=1, Criteria1:=aryPartNos(i)

'// Get the row numbers of the first and last record for this part no. //
lFirstRecordRow = .Resize(.Rows.Count - 1).Offset(1) _
.SpecialCells(xlCellTypeVisible).Row

lLastRecordRow = .Resize(.Rows.Count - 1).Offset(1) _
.SpecialCells(xlCellTypeLastCell).Row

'// For the first to last row/record for this part no... //
For lRow = lFirstRecordRow To lLastRecordRow
'// rngPartNo.Parent refers to the worksheet; thus, this gets a hard //
'// reference to .Cells. This is where you want to start looking at //
'// needed adjustments for which columns hold particular data on your //
'// actual project. //
If .Parent.Cells(lRow, "G").Value >= 0 Then
'// In the example data, Col G held OHRunTtl data, so if the row //
'// we are checking in Col G is >=0, then return in Col I, resized //
'// to two cols to include Col J. //
'// You may wish to study the help topics for Cells, Resize, Offset //
.Parent.Cells(lRow, "I").Resize(, 2).Value = "OK"
Else
'// If less than 0, we need to do some extra... //

'// resets//
lRowInner = 0
bolExit = False

'// First we'll try looking at below rows for the same part no. in //
'// OHRunTtl columns to see if we get back up to 0 or higher. If //
'// we find a >=0 val anywhere for the part no., we'll grab the //
'// OrderNum and date, set a flag, and stop looking. //
Do While lRowInner + lRow < lLastRecordRow And Not bolExit
lRowInner = lRowInner + 1

If .Parent.Cells(lRow + lRowInner, "G").Value >= 0 Then

.Parent.Cells(lRow, "I").Resize(, 2).Value = _
Array(.Parent.Cells(lRow + lRowInner, "C").Value, _
.Parent.Cells(lRow + lRowInner, "H").Value)

bolExit = True
End If
Loop

'// If we did not set the flag above, then we didn't find a >=0 val,//
'// so we'll mark No Supply. //
If Not bolExit Then
.Parent.Cells(lRow, "I").Resize(, 2).Value = "No Supply"
End If
End If
Next
Next
'// Redisplay all rows and ditch the drop-down arrows. //
.Parent.ShowAllData
.Parent.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub

Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=False)
End Function

 

[VoG]

I think that you just need to change

Set wks = ThisWorkbook.Worksheets("ExampleSheet")

to

Set wks = ActiveWorkbook.Worksheets("ExampleSheet")

Please use code tags when posting code.

 

[JGARDNER-AIT]

I think that you just need to change

Set wks = ThisWorkbook.Worksheets("ExampleSheet")

to

Set wks = ActiveWorkbook.Worksheets("ExampleSheet")

Please use code tags when posting code.

Thank you VoG!