Stuck extracting Vendor numbers only using VB, fully working, but just cant get them to appear.

[Dave01]

Hi, originally I got a lot of help with the code to make this work, but now the requirement is to get the vendor numbers to appear in tab 3 - Pay Proposal Report. Exvery thing is extracted and sorted really well, but it refuses to put in vendor numbers. Help modyifing the code so it will do this would be great.

if you follow the link and open the spreadsheet you will see it

spreadsheet

in short it needs to look at tab 1 find the vendor number, extract the number and list them in column A7 onwards.

hope you can help.

Many thanks, and a happy Christmas.

 

[jasonb75]

Where is the vendor number being extracted from?

Which part of the code should be picking up the vendor numbers?

I tried running your code, but my laptop doesn't appear to be able to run it, it freezes at the point where you try to autofilter the entire sheet (that is never going to be a good idea).

 

[Dave01]

Hi, thanks for the reply - it doesnt matter as long as the end result ends up with the vendor numbers in the code.so all the data that is populated comes off tab yellow - 1)download Raw Proposal, and ends up in 3)payproposal Report, just more formatted and in order, so the vendor numbers are comming off the tab download proposal. The difference with the vendors number compaired to the others is that there are no headers for it, one could easily be put in each time though, as the SAP report wont do it.

Its seems that what gets picked up is in this code

Sheets("3) Pay Proposal Report").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
   
     Dim LastRow As Long, LastRow2 As Long, i As Long, srcWS As Worksheet, desWS As Worksheet, headerArray As Variant, fnd As Range, x As Long: x = 2
    Set srcWS = Sheets("1) Download RAW Proposal")
    Set desWS = Sheets("3) Pay Proposal Report")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Intersect(srcWS.Rows("8:" & LastRow), srcWS.Columns("C:C")).Copy desWS.Cells(4, 1)
    headerArray = Array("CoCd", "DocumentNo", "type", "Document Date", "Bline Date", "FC gross amount", "Tot.ded.in FC", "Net amount in FC", "Crcy", "Err")
    For i = LBound(headerArray) To UBound(headerArray)
        Set fnd = srcWS.Rows(6).Find(headerArray(i), LookIn:=xlValues, lookat:=xlPart)
        Intersect(srcWS.Rows("8:" & LastRow), srcWS.Columns(fnd.Column)).Copy desWS.Cells(4, x)
        x = x + 1
    Next i
    LastRow2 = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With desWS.Range("L4")
        .Formula = "=IFERROR(IF(ISBLANK(K4),"""",VLOOKUP(K4,Lookups!A:B,2,FALSE)),"""")"
        .AutoFill .Resize(LastRow2 - 4, 1)
    End With
    Sheets("3) Pay Proposal Report").Select
    Columns("H:H").Select
    Range("H2").Activate

and then in tab 3) it puts it in this tab, with this code

End With
    Range("B1:I1").Select
   
     Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$L$1048543").AutoFilter Field:=2, Criteria1:="<>"
    Sheets("Lookups").Select
    Sheets("temp").Visible = True
    Sheets("3) Pay Proposal Report").Select
    Cells.Select
    Selection.Copy
    Sheets("temp").Select
    Cells.Select
    ActiveSheet.Paste
    Sheets("1) Download RAW Proposal").Select
    Rows("1:6").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("temp").Select
    Range("A1").Select
    Selection.Insert Shift:=xlDown
    Sheets("3) Pay Proposal Report").Select
    Cells.Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Sheets("temp").Select
    Range("C6:T6").Select
    Selection.Cut Destination:=Range("A6:R6")
    Range("C6:R6").Select
    Selection.Cut Destination:=Range("B6:Q6")
    Range("D6:E6").Select
    Selection.Cut Destination:=Range("C6:D6")
    Range("G6:M6").Select
    Selection.Cut Destination:=Range("E6:K6")
    Range("K6").Select
    Selection.Cut Destination:=Range("J6")
    Range("Q6").Select
    Selection.Cut Destination:=Range("K6")
    Range("L6").Select
    ActiveCell.FormulaR1C1 = "SAP Error Code As Text"
    Range("M6").Select
    ActiveCell.FormulaR1C1 = "Notes And Comments"
    Range("K6").Select
    ActiveCell.FormulaR1C1 = "Error Code"
    Range("J6").Select
    ActiveCell.FormulaR1C1 = "Currency"
    Range("I6").Select
    ActiveCell.FormulaR1C1 = "  Net Amount In F.C"
    Range("H6").Select
    ActiveCell.FormulaR1C1 = "     Total Deductions In F.C"
    Range("G6").Select
    ActiveCell.FormulaR1C1 = "   FC Gross Amount"
    Range("C6").Select
    ActiveCell.FormulaR1C1 = "Document Number"
    Range("D6").Select
    ActiveCell.FormulaR1C1 = "Transaction Type"
    Range("B6").Select
    ActiveCell.FormulaR1C1 = "Company Code"
    Range("A1:D5").Select
    Selection.ClearContents
    Rows("1:4").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.Delete Shift:=xlToLeft
    Range("M6").Select
    Columns("L:L").EntireColumn.AutoFit
    Columns("M:M").ColumnWidth = 40.43
    Rows("6:6").Select

I have a lot of formatting like bold, etc which slows it down, something I want to get rid of eventually.

it seems to freeze - but it doesnt, its just working through the code, although it appears to freeze, I get that, but then it all comes up.

 

[jasonb75]

It was actaully the copy and paste below the filter that was causing it to freeze / go slow, I changed that from Cells to UsedRange and it runs in about 10 seconds.

The reason the vendor numbers are missing is because of the filtering and the fact that they are not on the same row as the rest of the data.

Do you want the vendor number formatted the same as it is in the raw data? i.e. 10 digits with leading zeros?

I've already removed the formatting code to make it a bit easier to follow the rest, when I ran it and did a quick check against yours to compare the results, I noticed an anomoly, take a look at row 341 in the proposal report of the sample file, is that meant to be there? (several similar rows noticed).

If the SAP report is always in the same format, then the formatting can be preset rather than re-applying it each time.

While I'm waiting on your feedback regarding the above points, I'll make a start on cleaning it up a bit between the visits from the in-laws and out-laws, but with all of the festive disturbances, it might take a couple of days to get it finished though.

 

[Dave01]

wow that you, thats great. the vendor numbers - Vendor 0000077683

ideally 77683, but to get the numbers in there would be great.

thank you so much for your help.

 

[jasonb75]

I think that this should do it. Please use a copy of your workbook for testing, keep the original as a backup if needed.

Before running the code, I suggest that you give your Report sheet a good clean up by deleting everying except the headers in rows 1 to 5, columns A to M. I've removed the header setup and formatting from the code so you will need to preserve the originals (the code will not delete them).

Follow the steps below to delete everything that shouldn't be there, this includes deleting rows and columns that appear to be emtpy outside of the data range which were bloated by the part in your original code that was causing it to run very slow.

First select A6, then press Shift Ctrl and Down Arrow, with the cursor over the selection, right click > Delete > Entire Row.
Next select N1, then press Shift Ctrl and Right Arrow, with the cursor over the selection, right click > Delete > Entire Column.
Delete the 'Temp' sheet (no longer needed).
Save the workbook.

Once done, try running the code below, hopefully this will be an improvement on what you currently have.

Option Explicit
Sub PrepareSAPPayReport()
With Application
    .ScreenUpdating = False
    .Calculation = xlManual
End With
Dim wsRep As Worksheet, wsRAW As Worksheet, dRow As Long, lRow As Long, rw As Long, cl As Range
    Set wsRep = Sheets("3) Pay Proposal Report")
    Set wsRAW = Sheets("1) Download RAW Proposal")
    rw = 6
With wsRep
    dRow = .Cells(.Rows.Count, 2).End(xlUp).Row
    If dRow >= 6 Then .Range("6:" & dRow).EntireRow.Delete
End With
With wsRAW
    lRow = .Cells(.Rows.Count, 31).End(xlUp).Row 'RAW Download last row in column AE
    For Each cl In .Range("AE2:AE" & lRow).SpecialCells(xlConstants)
        If IsNumeric(cl.Value) Then
            Intersect(.Range(.Cells(cl.Row, 5), cl), .Range("E:E,G:G,M:N,Q:Q,V:W,Y:Y,AB:AB,AE:AE")).Copy wsRep.Cells(rw, 2)
            wsRep.Cells(rw, 1).Value = Mid(.Range("C1", cl.Offset(, -28)).Find("Vendor", cl.Offset(, -28), , xlPart, , xlPrevious), 8, 255)
            wsRep.Cells(rw, 12).Value = Sheets("Lookups").Range("A3:A73").Find(wsRep.Cells(rw, 11).Value, , , xlWhole, , xlNext).Offset(, 1).Value
            rw = rw + 1
        End If
    Next
End With
With Application
    .Calculation = xlAutomatic
    .ScreenUpdating = True
End With
End Sub

 

[jasonb75]

I wasn't happy with the code in my previous post (too slow and clunky), taking a different approach to it, this is much faster. Fixes a few of the things mentioned in your notes as well.

Note that this does make some changes to the RAW download data by deleting anything in column C that is not a vendor number. If you try to run it twice on the same data it will still run, but much slower and it will lose the vendor numbers completely.

See notes in my previous post about cleaning up the sheet before running the code.

Option Explicit
Sub PrepareSAPPayReport()
With Application
    .ScreenUpdating = False
    .Calculation = xlManual
End With
Dim wsRep As Worksheet, wsRAW As Worksheet, dRow As Long, lRow As Long, rwRep As Long, c As Range, cl As Range, tmpRng As Range
    Set wsRep = Sheets("3) Pay Proposal Report")
    Set wsRAW = Sheets("1) Download RAW Proposal")
With wsRep
    dRow = .Cells(.Rows.Count, 2).End(xlUp).Row
    If dRow >= 6 Then .Range("6:" & dRow).EntireRow.Delete
End With
With wsRAW
    lRow = .Cells(.Rows.Count, 31).End(xlUp).Row
    For Each c In .Range("C2:C" & lRow)
        If Left(c.Value, 7) = "Vendor " Then c.Value = Mid(c.Value, 8, 255) Else c.Value = c.Offset(-1).Value
    Next
    For Each cl In .Range("AE2:AE" & lRow).SpecialCells(xlConstants)
        If IsNumeric(cl.Value) Then
            If tmpRng Is Nothing Then
                Set tmpRng = cl
            Else
                Set tmpRng = Application.Union(tmpRng, cl)
            End If
        End If
    Next
    Intersect(tmpRng.EntireRow, .Range("C:C,E:E,G:G,M:N,Q:Q,V:W,Y:Y,AB:AB,AE:AE")).Copy wsRep.Range("A6")
End With
With wsRep
    rwRep = .Cells(Rows.Count, 2).End(xlUp).Row - 5
    .Range("E6").Resize(rwRep).TextToColumns FieldInfo:=Array(1, 4)
    .Range("F6").Resize(rwRep).TextToColumns FieldInfo:=Array(1, 4)
    .Range("G6").Resize(rwRep).TextToColumns FieldInfo:=Array(1, 1), DecimalSeparator:=",", ThousandsSeparator:="."
    .Range("H6").Resize(rwRep).TextToColumns FieldInfo:=Array(1, 1), DecimalSeparator:=",", ThousandsSeparator:="."
    .Range("I6").Resize(rwRep).TextToColumns FieldInfo:=Array(1, 1), DecimalSeparator:=",", ThousandsSeparator:="."
    With .Range("L6").Resize(rwRep)
        .FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-1],Lookups!R1C1:R100C2,2,0)&"""","""")"
        .Value = .Value
    End With
End With
With Application
    .Calculation = xlAutomatic
    .ScreenUpdating = True
End With
End Sub

 

[Dave01]

Thant is amazing, works perfect, thank you so much for your hard work. Me and my team thank you very much, Its so fast and does a great job of sorting the data, and formatting it correctly. Just perfect. Best wishes in the new year.