Needs Help With Revising Data Extractor Solution

Noah
Noah used Ask the Experts™
on
Greetings Experts

Previously, I had marked my solution in this question below.
https://www.experts-exchange.com/questions/29162831/Needs-Help-With-Data-Extraction-Using-Find.html

What I was trying to do was extract data from files and put it in a table. There is a sample data file here: Sample1.xlsx
 

Original Table View:
Capture.PNG
Original Solution File:
Data-Extractor-For-Tax-Invoice.xlsm

Now the thing is I am trying to add a field called Supplier Name. In the data files where the data is taken from, it will always be in cell D1.

The new data table I am trying to create:
Capture1.PNG
For now, I have also contacted the expert who provided me the original solution.

Any help is much appreciated! :)
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Senior Developer
Commented:
E.g. (untested)

Private Function ExtractData(ByVal CSourceSheet As Excel.Worksheet, ByVal CDestinationTable As Excel.ListObject, ByRef CParsingPoints() As Variant) As Boolean

  Const HEADER_DOCUMENT_NUMBER As Long = 0
  Const HEADER_DOCUMENT_DATE As Long = 1
  Const HEADER_SERIAL_ORDER_NUMBER As Long = 2
  Const COLUMN_PART_NUMBER As Long = 3
  Const COLUMN_CUSTOMER_PURCHASE_ORDER As Long = 4
  Const COLUMN_QUANTITY As Long = 5

  On Local Error GoTo LocalError

  Dim CellCustomerPurchaseOrder As Excel.Range
  Dim CellPartNumber As Excel.Range
  Dim CellQuantity As Excel.Range

  Dim CurrentRowOffset As Long

  Dim HeaderDocumentNumber As String
  Dim HeaderDocumentDate As Date
  Dim HeaderSerialOrderNumber As String
  Dim HeaderSupplierName As String
  Dim ColumnCustomerPurchaseOrder As String
  Dim ColumnPartNumber As String
  Dim ColumnQuantity As Double

  HeaderDocumentNumber = CSourceSheet.Cells.Find(CParsingPoints(HEADER_DOCUMENT_NUMBER), , xlValues, xlWhole, xlByRows, xlNext, True, False).Offset(, 1).Value
  HeaderDocumentDate = CDate(CSourceSheet.Cells.Find(CParsingPoints(HEADER_DOCUMENT_DATE), , xlValues, xlWhole, xlByRows, xlNext, True, False).Offset(, 1).Value)
  HeaderSerialOrderNumber = CSourceSheet.Cells.Find(CParsingPoints(HEADER_SERIAL_ORDER_NUMBER), , xlValues, xlWhole, xlByRows, xlNext, True, False).Offset(, 1).Value
  HeaderSupplierName = CSourceSheet.Cells(1, 4).Value
  Set CellPartNumber = CSourceSheet.Cells.Find(CParsingPoints(COLUMN_PART_NUMBER), , xlValues, xlWhole, xlByRows, xlNext, True, False).Offset(2)
  Set CellCustomerPurchaseOrder = CSourceSheet.Cells.Find(CParsingPoints(COLUMN_CUSTOMER_PURCHASE_ORDER), , xlValues, xlWhole, xlByRows, xlNext, True, False).Offset(2)
  Set CellQuantity = CSourceSheet.Cells.Find(CParsingPoints(COLUMN_QUANTITY), , xlValues, xlWhole, xlByRows, xlNext, True, False).Offset(2)
  CurrentRowOffset = 0
  Do
    If Len(Trim(CellPartNumber.Offset(CurrentRowOffset).Value & "")) > 0 Then
      ColumnPartNumber = CellPartNumber.Offset(CurrentRowOffset).Value
      ColumnCustomerPurchaseOrder = CellCustomerPurchaseOrder.Offset(CurrentRowOffset).Value
      ColumnQuantity = CDbl(CellQuantity.Offset(CurrentRowOffset).Value)
      TableAddRow CDestinationTable, Array(HeaderSupplierName, HeaderDocumentNumber, HeaderDocumentDate, HeaderSerialOrderNumber, ColumnCustomerPurchaseOrder, ColumnPartNumber, ColumnQuantity)
      CurrentRowOffset = CurrentRowOffset + 1
    Else
      Exit Do
    End If
  Loop

  Set CellCustomerPurchaseOrder = Nothing
  Set CellPartNumber = Nothing
  Set CellQuantity = Nothing
  Exit Function

LocalError:
  Debug.Print "ExtractData(): Error " & Err.Number & " while extracting data." & vbCrLf & vbTab & Err.Description

End Function

Open in new window

NoahHardware Tester and Debugger

Author

Commented:
@ste5an Oh, That was quick! Yea it works the way I want it now. It's just that I had to make the table "bigger" by adding one more column so that the copied data can be pasted.

Thanks so much again!
NoahHardware Tester and Debugger

Author

Commented:
@ste5an Actually, my colleague recommended that I take all the text available in row 1 of the data file and this is because, we want to avoid the problem that the data is in another column... How should I do this in line 29 of the code? :)
Success in ‘20 With a Profitable Pricing Strategy

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

ste5anSenior Developer
Commented:
E.g.

Private Function ExtractFirstRowText(ByVal CSheet As Excel.Worksheet) As String

  Dim Count As Long
  Dim Result As String

  Count = 0
  Do While Count < 255
    Count = Count + 1
    If Len(Trim(CSheet.Cells(1, Count).Value & "")) > 0 Then
      Result = Result & CSheet.Cells(1, Count).Value & ", " 
    End If
  Loop

  If Len(Result) > 0 Then
    Result = Left(Result, Len(Result) - 2)
  End If

  ExtractFirstRowText = Result

End Function

Open in new window

NoahHardware Tester and Debugger

Author

Commented:
@ste5an Thank you for your reply, so in the code above which I have marked as the solution. Is this the correct way to replace the code?

HeaderSupplierName =  CSourceSheet.Cells.Find(CParsingPoints(ExtractFirstRowTes), , xlValues, xlWhole, xlByRows, xlNext, True, False).Value

Open in new window


It doesn't work for now...
ste5anSenior Developer
Commented:
Nope.

HeaderSupplierName = ExtractFirstRowText(CSourceSheet)

Open in new window

NoahHardware Tester and Debugger

Author

Commented:
Excellent! Thanks for your help again :)

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial