i got lost in when making this code, need help

[broyles32]

Who can tell me if the following code is repeating actions that it has previously done within the code?




Public Sub RetrievePOData()
Dim LastCols As Long, LastCols1 As Long
Dim LastRow As Long, LastColDS As Long
Dim strPartNums As String, mySQLHeader As String
Dim mySQL As String
Dim myConn As New ADODB.Connection
Dim myRS As New ADODB.Recordset

Sheets("POs").Activate

ActiveWindow.FreezePanes = False

'Sort PO Data by Part #
LastRow = Range("A65536").End(xlUp).Row
Range("A2", Range("N" & LastRow)).Sort Key1:=Range("D2") _
, Order1:=xlAscending, Order2:=xlAscending _
, Header:=xlNo, OrderCustom:=1, MatchCase:=False _
, Orientation:=xlTopToBottom
' Assemble the Part #'s to send to MAPICS query
LastRow = Sheets("POs").Range("A65536").End(xlUp).Row
For Each PartNum In Sheets("POs").Range("D2:D" & LastRow)
If PartNum <> PartNum.Offset(-1, 0).Value Then
strPartNums = strPartNums & Chr(39) & Trim(PartNum.Text) & Chr(39) & ","
End If
Next PartNum

strPartNums = Left(strPartNums, Len(strPartNums) - 1)

If myConn.State = 0 Then
myConn.Open "Provider=MSDASQL.1;Password=xs892kmfg;Persist Security Info=True;User ID=ddt;Data Source=AMFLIB1;Initial Catalog=S1099F6P"
End If

mySQLHeader = "SELECT ITEMBL.ITNBR, ITEMBL.MALQT, ITEMBL.MOHTQ, ITEMBL.MPUPQ FROM S1099F6P.AMFLIB1.ITEMBL ITEMBL WHERE "

mySQL = mySQLHeader & "(ITEMBL.ITNBR in (" & strPartNums & "))"
' Debug.Print mySQL
myRS.Open mySQL, myConn

Sheets("POs").Range("Q65536").End(xlUp).Offset(1, 0).CopyFromRecordset myRS

myRS.Close
myConn.Close

mySQL = ""
' Trim excess spaces at the end of the retrieved Part #'s
LastRow2 = Range("Q65536").End(xlUp).Row
With Range("V2:V" & LastRow2)
.Formula = "=Trim(Q2)"
.Value = .Value
.Copy Range("Q2:Q" & LastRow2)
.ClearContents
End With

' Add formula to replace all Qty's On Hand that may have changed
LastRow1 = Range("A65536").End(xlUp).Row
LastRow2 = Range("Q65536").End(xlUp).Row
With Range("I2:I" & LastRow1)
.Formula = "=VLOOKUP(D2,$Q$2:$S$" & LastRow2 & ",3,FALSE)"
.Value = .Value
End With

'SORT TEMP ARRAY BY PART #
LastRow = Range("Q65536").End(xlUp).Row
Range("Q2", Range("T" & LastRow)).Sort Key1:=Range("Q2") _
, Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False _
, Orientation:=xlTopToBottom
Range("C:D, K:K").Copy
Range("AA:AA").PasteSpecial

LastCols = Range("IV1").End(xlToLeft).Column
CellsAcross1 = 8
CellsDown1 = Range("A65536").End(xlUp).Row
Set rngIn1 = Sheets("POs").Range("A2:N" & CellsDown1)
tmpArr1 = rngIn1.Value
ReDim newArr(1 To CellsDown1, 1 To CellsAcross1)
Set TheRange = Sheets("POs").Range("A2:H" & CellsDown1)
ni = 0
myPrevious = ""

For W = 1 To CellsDown1
nameIn1 = tmpArr1(W, 4)
If Trim(nameIn1) <> Trim(myPrevious) Then
If Not tmpArr1(W, 7) Like "BFE*" And Not tmpArr1(W, 5) Like "O/*" _
And Not tmpArr1(W, 5) Like "POWDERCO*" Then
ni = ni + 1
For j = 1 To CellsAcross1
If j <= 5 Then ' CO #, Job #, PO #, Part #, Description
newArr(ni, j) = Trim(tmpArr1(W, j))
ElseIf j = 6 Then ' Buyer #
newArr(ni, j) = Trim(tmpArr1(W, 7))
ElseIf j = 7 Then ' Req'd Qty
If origQTY <> "" Then
origQTY = 0
newArr(ni, j) = Trim(tmpArr1(W, 10))
origQTY = tmpArr1(W, 10)
ElseIf origQTY = "" Then
origQTY = tmpArr1(W, 10)
End If
ElseIf j = 8 Then ' Req'd Qty
newArr(ni, j) = Trim(tmpArr1(W, 11))
Exit For
End If
Next j
End If

ElseIf Trim(nameIn1) = Trim(myPrevious) Then
If Not tmpArr1(W, 7) Like "BFE*" And Not tmpArr1(W, 5) Like "O/*" _
And Not tmpArr1(W, 5) Like "POWDERCO*" Then

For j = 1 To CellsAcross1
If j = 7 Then
origQTY = origQTY + tmpArr1(W, 10)
If W + 1 < CellsDown1 Then
If Trim(nameIn1) <> Trim(tmpArr1(W + 1, 4)) Then
newArr(ni, j) = origQTY
Exit For
ElseIf Trim(nameIn1) = Trim(tmpArr1(W + 1, 4)) Then
Exit For
End If
ElseIf W + 1 = CellsDown1 Then
newArr(ni, j) = origQTY
Exit For
End If
End If
Next j
End If
End If
myPrevious = Trim(nameIn1)
If W + 1 >= CellsDown1 Then
Exit For
End If
Next W
TheRange.Value = newArr

Range("I:P").Columns.ClearContents

' Add Allocated, On Hand & Purchasing On Order Quantities
CellsAcross1 = 8
CellsDown1 = Range("A65536").End(xlUp).Row

Set rngIn1 = Sheets("POs").Range("A1:H" & CellsDown1)
tmpArr1 = rngIn1.Value

CellsAcross2 = 4
CellsDown2 = Sheets("POs").Range("Q65536").End(xlUp).Row

Set rngIn2 = Sheets("POs").Range("Q2:T" & CellsDown2)
tmpArr2 = rngIn2.Value

ReDim newArr(1 To CellsDown1, 1 To 11)

Set TheRange = Sheets("POs").Range("A1:K" & CellsDown1)

ni = 1
myPrevious = ""
origWKCTR = ""
FoundTrue = False
prevxj = 0

For W = 2 To CellsDown1
nameIn1 = tmpArr1(W, 4)
' If nameIn1 = "M897320" Then
' X = X
' End If
ni = ni + 1
For j = 1 To CellsAcross1 + 3
If j <= 7 Then
newArr(ni, j) = Trim(tmpArr1(W, j))
ElseIf j >= 8 And j < CellsAcross1 + 3 Then
For xy = 1 To CellsDown2
nameIn2 = tmpArr2(xy, 1)
If Trim(nameIn1) = Trim(nameIn2) Then
FoundTrue = True
For xj = 2 To CellsAcross2
If xj > prevxj Or xj = CellsAcross2 Then
newArr(ni, j) = Trim(tmpArr2(xy, xj))
prevxj = xj
Exit For
End If
Next xj
If FoundTrue = True Then
Exit For
End If
End If
Next xy
ElseIf j = CellsAcross1 + 3 Then
newArr(ni, j) = Trim(tmpArr1(W, 8))
End If
Next j
If W >= CellsDown1 Then
Exit For
End If
FoundTrue = False
prevxj = 0
Next W
TheRange.Value = newArr




Range("1:1").ClearContents
Range("L:IV").Clear

myTitleArray = Array("CO #", "Job #", "PO #", "Part #", "Description", "Buyer #", "Qty Req'd", "Alloc. Qty", "On Hand Qty.", "Purch On Order Qty.", "MO #")
With Range("A1:K1")
.Value = myTitleArray
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Range("F2:K65536")
.HorizontalAlignment = xlCenter
.NumberFormat = "0"
End With

Cells.Columns.AutoFit

LastRow = Range("A65536").End(xlUp).Row
For Each short In Range("I2:I" & LastRow)
If short = 0 Then
With Range("I" & short.Row)
.Font.Color = RGB(255, 0, 0)
.Font.Bold = True
End With
End If
Next short

LastRow = Range("A65536").End(xlUp).Row
For Each short In Range("J2:J" & LastRow)
If short = 0 Then
With Range("J" & short.Row)
.Font.Color = RGB(255, 0, 0)
.Font.Bold = True
End With
End If
Next short

Cells.WrapText = True
Cells.WrapText = False

Range("A1:K" & LastRow).Select
Selection.Columns.AutoFit

End Sub