Del. 2 - Hvordan hentes specifik data fra excel til word

Rem VERSION 2
Rem =========
Rem Reference til Microsoft Excel er sat i VBA (Alt+F11/Tools/References/Microsoft Excel 12.0 Object Library
Rem VBA-koden anbringes i VBA / ThisDocument
Rem ========================================

Const stiTilPriser = "C:\Users\peter\Desktop\ChristianLeu\Priser.xls"          '<-- ændres
Const prisArkNavn = "InvenSalesPriceList"
Dim xlsPriser
Dim antalTabeller As Integer, antalRækker As Integer
Public Sub HentPriser()
    HouseKeeping
       
    TraverserDokument

    lukPriser
    MsgBox "Prissætning er afsluttet"
End Sub
Private Sub HouseKeeping()
    Set xlsPriser = CreateObject("Excel.Application")
    xlsPriser.Workbooks.Open stiTilPriser
       
    antalTabeller = ActiveDocument.Tables.Count
    antalRækker = ActiveDocument.Tables(1).Rows.Count
End Sub
Private Sub TraverserDokument()
Dim ræk, kolonne2, vareNr As Long, pris, p1
Dim toPriser As Variant
On Error GoTo fejl
    Application.ScreenUpdating = False
   
    For ræk = 1 To antalRækker
        With ActiveDocument.Tables(1)
            kolonne2 = Trim(.Cell(ræk, 2))
            If Len(kolonne2) > 9 Then
                toPriser = Split(kolonne2, Chr(13))
                p1 = ""
                For pp = 0 To UBound(toPriser)
                    If IsNumeric(toPriser(pp)) = True And Len(toPriser(pp)) = 6 Then
                        vareNr = toPriser(pp)
                        pris = findPris(vareNr)
                        p1 = p1 & Format(pris, "###,###.00") & Chr(13)
                    Else
                        p1 = p1 & Chr(13)
                    End If
                Next pp
                .Cell(ræk, 5).Select
                Selection.Text = p1
            Else
                vareNr = Left(kolonne2, Len(kolonne2) - 2)  'blank + slutcelle fjernes
                pris = findPris(vareNr)
                .Cell(ræk, 5).Select
                Selection.Text = Format(pris, "###,###.00")
            End If
        End With
    Next ræk
    Exit Sub
   
fejl:
    MsgBox "Fejl erkendt i tabelrække: " & CStr(ræk)
    lukPriser
End Sub
Private Sub lukPriser()
    With xlsPriser
        .Application.Quit
    End With
   
    Set xlsPriser = Nothing
End Sub
Private Function findPris(vareNr)
Dim række As Long
    With xlsPriser.Range("A1:A65000")
        Set C = .Find(vareNr, LookIn:=xlValues, LookAt:=xlWhole)
        If Not C Is Nothing Then
            række = C.Row
        Else
            række = 0
        End If
    End With
       
    If række <> 0 Then
        findPris = xlsPriser.Range("C" & række)
    Else
        findPris = 0
    End If
End Function

Så fik jeg endelig afprøvet det.

Den tager ikke data på formen 'x-xxx-x' som den gjorde i version 1.

Ok - har misforstået x-xxx-x - skal nok få ordnet denne. Er der flere varianter?

Nej der er kun de to typer, tak.

Dvs 999999 & 9-999-9 er valide varenr?

x-xxx-x varenr er de anført på samme måde i prislisten - eller uden - ??

De står på samme måde i prislisten som i word, dvs med '-' bindestregen.

Ok - & tak..

Fungerer det som det skal?

Næsten.

Har stadig problemer med formatet x-xxx-x og at den udvider cellerne med 2 tomme linier.

Kunne du ikke sende lidt dokumentation af de problemer, som du nævner?

Har sendt dig en mail med filerne.

Poster lige Supertekst's løsning og lukker tråden da problemet er løst!


Rem VERSION 3
Rem =========
Rem Reference til Microsoft Excel er sat i VBA (Alt+F11/Tools/References/Microsoft Excel 12.0 Object Library
Rem VBA-koden anbringes i VBA / ThisDocument
Rem ========================================

Const stiTilPriser = "C:\Users\admin\Desktop\Priser.xls"          '<-- ændres
Const prisArkNavn = "InvenSalesPriceList"
Dim xlsPriser
Dim antalTabeller As Integer, antalRækker As Integer
Public Sub HentPriser()
    HouseKeeping
       
    TraverserDokument

    lukPriser
    MsgBox "Prissætning er afsluttet"
End Sub
Private Sub HouseKeeping()
    Set xlsPriser = CreateObject("Excel.Application")
    xlsPriser.Workbooks.Open stiTilPriser
       
    antalTabeller = ActiveDocument.Tables.Count
    antalRækker = ActiveDocument.Tables(1).Rows.Count
End Sub
Private Sub TraverserDokument()
Dim ræk, kolonne2 As String, vNr As Variant, vareNr As Long, vareNr2 As String, pris, p1
Dim toPriser As Variant, slutTegn As String
On Error GoTo fejl
    Application.ScreenUpdating = False
   
    For ræk = 1 To antalRækker
        With ActiveDocument.Tables(1)
            kolonne2 = Trim(.Cell(ræk, 2))
            toPriser = Split(kolonne2, Chr(13))
            p1 = ""
           
            For pp = 0 To UBound(toPriser)
                If pp = UBound(toPriser) - 1 Then
                    slutTegn = ""
                Else
                    slutTegn = Chr(13)
                End If
               
                vNr = toPriser(pp)
                If vNr <> "" And vNr <> Chr(7) Then
                    If InStr(vNr, "-") > 0 Then
                        vareNr2 = vNr
                        pris = findPris2(vareNr2)
                    Else
                        vareNr = vNr
                        pris = findPris(vareNr)
                    End If
                    p1 = p1 & Format(pris, "###,##0.00") & slutTegn
                Else
                    If vNr = "" Then
                        p1 = p1 & slutTegn
                    End If
                End If
            Next pp
            .Cell(ræk, 5).Select
            Selection.Text = p1
        End With
    Next ræk
    Exit Sub
   
fejl:
    MsgBox "Fejl erkendt i tabelrække: " & CStr(ræk)
Stop
'Resume Next
    lukPriser
End Sub
Private Sub lukPriser()
On Error Resume Next

    With xlsPriser
        .Application.Quit
    End With
   
    Set xlsPriser = Nothing
End Sub
Private Function findPris(vareNr)
Dim række As Long
    With xlsPriser.Range("A1:A65000")
        Set C = .Find(vareNr, LookIn:=xlValues, LookAt:=xlWhole)
        If Not C Is Nothing Then
            række = C.Row
        Else
            række = 0
        End If
    End With
       
    If række <> 0 Then
        findPris = xlsPriser.Range("C" & række)
    Else
        findPris = 0
    End If
End Function
Private Function findPris2(vareNr2)
Dim ræk
    For ræk = 1 To 65000
        vNr = xlsPriser.Range("A" & ræk)
       
        If vNr = "" Then
            findPris2 = 0
            Exit Function
        Else
            If vNr = vareNr2 Then
                findPris2 = xlsPriser.Range("C" & ræk)
                Exit Function
            End If
        End If
    Next ræk
End Function