04. april 2012 - 13:03Der er
12 kommentarer og 1 løsning
Del. 2 - Hvordan hentes specifik data fra excel til word
Forsættelse af tidligere spørgsmål hvor supertekst gav følgende løsning:
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\opdateret katalog 2012\Prisliste April 2012.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, p2 Dim toPriser As Variant On Error GoTo fejl Application.ScreenUpdating = False
For ræk = 1 To antalRækker With ActiveDocument.Tables(1) kolonne2 = .Cell(ræk, 2) If Len(kolonne2) > 8 Then toPriser = Split(kolonne2, Chr(13)) p1 = toPriser(0) p2 = toPriser(1)
pris1 = findPris(p1) pris2 = findPris(p2) pris = Format(pris1, "###,###.00") & Chr(13) & Format(pris2, "###,###.00") .Cell(ræk, 5).Select Selection.Text = pris 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
Kan den tilrettes så den henter data ind på flere end 2 linjer i hver række?
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
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
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.