Von DAO3.6 zu ACEDAO

05/11/2009 - 15:16 von Marco | Report spam
Hallo Profis

Ich habe ein Problem und weiss da nicht mehr weiter.

Wir hatten ein VB Makro in Excel 2007 laufen, welches auf eine Access 2003
mdb Datenbank zugegriffen hat.
Jetzt wurde diese Datenbank ins ACCDB Format konvertiert und seit dem funzt
auch das Makro nicht mehr :-(

Ich hab mich bissi schlau gemacht und herausgefunden, dass es jetzt nicht
mehr die DAO3.6 als Library benötigt, sondern die ACEDAO, da nur die auf das
ACCDB Access Fileformat zugreifen kann.

Hab die Library zusàtzlich zur DAO3.6 eingebunden, aber erhalten leider
jetzt dennoch einen Fehler und zwar bei diesem Befehl:

If db Is Nothing Then Set db = OpenDatabase(sDBPath)

Was muss ich denn noch àndern, damit das Makro wieder làuft?

Kann mir da jemand helfen?

Vielen Dank

Gruss Marco

P.S. Hier das ganze Makro
-

Const sDBPath = "X:\Apps\MATCALC\MatCalc_d.accdb"
Global db As Database
Sub StartRueckstellungen()
Application.DisplayStatusBar = True
Application.StatusBar = "Programm làuft..."
fUpdate
fCreateSheet
Application.StatusBar = ""
End Sub
Function fUpdate()
Dim sh As Worksheet
Dim dARNR As Variant, dRow As Double, vData As Variant
Set sh = ThisWorkbook.Sheets("Daten")
dLastRow = sh.[a36000].End(xlUp).Row
For dRow = 2 To dLastRow
fDelContent sh, dRow
dARNR = sh.Cells(dRow, 1)
dARNR = Replace(Replace(dARNR, " ", ""), "-", "")
If Not dARNR = "" And IsNumeric(dARNR) Then
vData = fGetPrice(dARNR)
If Not IsEmpty(vData) Then
sh.Cells(dRow, 3) = vData(0)
sh.Cells(dRow, 4) = vData(1)
sh.Cells(dRow, 5) = vData(2)
End If
End If
Next
sh.Columns.AutoFit
sh.Range("A2:E" & dLastRow).Sort Key1:=Range("D2"), Order1:=xlAscending
End Function
Function fGetPrice(ByVal dARNR As Double) As Variant
Dim rsArt As Recordset, sSQL As String, vData(2) As Variant
If db Is Nothing Then Set db = OpenDatabase(sDBPath)
sSQL = "SELECT ArtPreisHKFix, LagerortNr_FK, LieferantenNr_FK FROM
t_Artikel WHERE ArtFirmaArtikelNr=" & dARNR
Set rsArt = db.OpenRecordset(sSQL, dbOpenForwardOnly)
If Not rsArt.RecordCount = 0 Then
If Not IsNull(rsArt!LieferantenNr_FK) And Not rsArt!LieferantenNr_FK
= "" Then
sSQL = "SELECT LiefName FROM t_Lieferanten WHERE
LiefernantenNr=" & rsArt!LieferantenNr_FK
Set rsLief = db.OpenRecordset(sSQL, dbOpenForwardOnly)
If Not rsLief.RecordCount = 0 Then vData(0) = rsLief!LiefName
End If
If Not IsNull(rsArt!LagerortNr_FK) And Not rsArt!LagerortNr_FK = ""
Then
sSQL = "SELECT LOBezeichnung FROM t_Lagerorte WHERE LagerortNr="
& rsArt!LagerortNr_FK
Set rsLO = db.OpenRecordset(sSQL, dbOpenForwardOnly)
If Not rsLO.RecordCount = 0 Then vData(1) = rsLO!LOBezeichnung
End If
vData(2) = rsArt!ArtPreisHKFix
fGetPrice = vData
End If
End Function
Function fDelContent(sh As Worksheet, dRow As Double)
With sh.Range("C" & dRow & ":E" & dRow)
.ClearContents: .ClearComments: .ClearFormats: .ClearNotes:
.ClearOutline
End With
End Function
Function fCreateSheet()
Dim wbNew As Workbook
Dim sh As Worksheet, shNew As Worksheet
Set sh = ThisWorkbook.Sheets("Daten")
Set wbNew = Application.Workbooks.Add
Set shNew = wbNew.Sheets(1)
shNew.Columns.Font.Size = 10: shNew.Columns.Font.Name =
"Arial"
shNew.Columns(1).ColumnWidth = 33.14: shNew.Columns(2).ColumnWidth
= 18
shNew.Columns(5).NumberFormat = "0.00":
shNew.Columns(6).NumberFormat = "0.00"
shNew.Cells(1, 1) = "Rückstellungen per"
shNew.Range(shNew.Cells(1, 1), shNew.Cells(1, 6)).Font.Size = 12
shNew.Range(shNew.Cells(1, 1), shNew.Cells(1, 6)).Font.Bold = True
shNew.Range(shNew.Cells(1, 1), shNew.Cells(1,
6)).Borders(xlEdgeBottom).LineStyle = 1
shNew.Cells(3, 1) = "Lager- und Kübelteile": shNew.Cells(3, 1).Font.Bold
= True
shNew.Cells(5, 1) = "Lieferant": shNew.Cells(5, 1).Font.Underline = True
shNew.Cells(5, 2) = "Artikelnr.": shNew.Cells(5, 2).Font.Underline =
True
shNew.Cells(5, 3) = "Lagerort": shNew.Cells(5, 3).Font.Underline = True
shNew.Cells(5, 4) = "Menge": shNew.Cells(5, 4).Font.Underline = True
shNew.Cells(5, 5) = "Preis fixiert": shNew.Cells(5, 5).Font.Underline =
True
shNew.Cells(5, 6) = "Total": shNew.Cells(5, 6).Font.Underline = True
shNew.Cells(6, 5) = "CHF": shNew.Cells(6, 6) = "CHF"
shNew.Cells(7, 1) = "Lager": shNew.Cells(7, 1).Font.Color = 16711680:
shNew.Cells(7, 1).Font.Underline = True
dRowNew = 9
dRowNewStart = dRowNew
dLastRow = sh.[a36000].End(xlUp).Row
For dRow = 2 To dLastRow
sLo = sh.Cells(dRow, 4)
If InStr(1, sLo, "K") = 0 Then
shNew.Cells(dRowNew, 1) = sh.Cells(dRow, 3)
shNew.Cells(dRowNew, 2) = sh.Cells(dRow, 1)
shNew.Cells(dRowNew, 3) = sh.Cells(dRow, 4)
shNew.Cells(dRowNew, 4) = sh.Cells(dRow, 2)
shNew.Cells(dRowNew, 5) = sh.Cells(dRow, 5)
shNew.Cells(dRowNew, 6).FormulaR1C1 = "=RC[-1]*RC[-2]"
dRowNew = dRowNew + 1
End If
Next
dRowNew = dRowNew + 1
shNew.Cells(dRowNew, 1) = "Lager"
shNew.Cells(dRowNew, 6).FormulaR1C1 = "=SUM(R[-2]C:R[-" & dRowNew -
dRowNewStart & "]C)"
dRowNew = dRowNew + 2
shNew.Cells(dRowNew, 1) = "Kundenauftràge"
dRowNew = dRowNew + 2
shNew.Cells(dRowNew, 1) = "Reserve"
dRowNew = dRowNew + 2
shNew.Cells(dRowNew, 1) = "Total Lager 1065":
shNew.Rows(dRowNew).Font.Bold = True
shNew.Cells(dRowNew, 6).FormulaR1C1 = "=SUM(R[-2]C:R[-6]C)"
dRowNew = dRowNew + 3
shNew.Cells(dRowNew, 1) = "Kübelteile": shNew.Cells(dRowNew,
1).Font.Color = 16711680
shNew.Cells(dRowNew, 1).Font.Underline = True
dRowNew = dRowNew + 2
dRowNewStart = dRowNew
For dRow = 2 To dLastRow
sLo = sh.Cells(dRow, 4)
If InStr(1, sLo, "K") > 0 Then
shNew.Cells(dRowNew, 1) = sh.Cells(dRow, 3)
shNew.Cells(dRowNew, 2) = sh.Cells(dRow, 1)
shNew.Cells(dRowNew, 3) = sh.Cells(dRow, 4)
shNew.Cells(dRowNew, 4) = sh.Cells(dRow, 2)
shNew.Cells(dRowNew, 5) = sh.Cells(dRow, 5)
shNew.Cells(dRowNew, 6).FormulaR1C1 = "=RC[-1]*RC[-2]"
dRowNew = dRowNew + 1
End If
Next
dRowNew = dRowNew + 1
shNew.Cells(dRowNew, 1) = "Total Kübel 3100":
shNew.Rows(dRowNew).Font.Bold = True
shNew.Cells(dRowNew, 6).FormulaR1C1 = "=R[-2]C+R[-" & dRowNew -
dRowNewStart & "]C"
dRowNew = dRowNew + 2
shNew.Cells(dRowNew, 1) = "Kostenarte-Zusammenfassung"
shNew.Cells(dRowNew, 1).Font.Underline = True
dRowNew = dRowNew + 1: shNew.Cells(dRowNew, 1) = "3100 / 3101":
shNew.Cells(dRowNew, 2) = "KL1"
shNew.Cells(dRowNew, 6).FormulaR1C1 = "=SUMIF(C[-3],RC[-4],C)"
dRowNew = dRowNew + 1: shNew.Cells(dRowNew, 1) = "3100 / 3102":
shNew.Cells(dRowNew, 2) = "KL2"
shNew.Cells(dRowNew, 6).FormulaR1C1 = "=SUMIF(C[-3],RC[-4],C)"
dRowNew = dRowNew + 1: shNew.Cells(dRowNew, 1) = "3100 / 3104":
shNew.Cells(dRowNew, 2) = "KL4"
shNew.Cells(dRowNew, 6).FormulaR1C1 = "=SUMIF(C[-3],RC[-4],C)"
dRowNew = dRowNew + 1: shNew.Cells(dRowNew, 1) = "3100 / 3105":
shNew.Cells(dRowNew, 2) = "KL5"
shNew.Cells(dRowNew, 6).FormulaR1C1 = "=SUMIF(C[-3],RC[-4],C)"
dRowNew = dRowNew + 1: shNew.Cells(dRowNew, 1) = "3100 / 3106":
shNew.Cells(dRowNew, 2) = "KL6"
shNew.Cells(dRowNew, 6).FormulaR1C1 = "=SUMIF(C[-3],RC[-4],C)"
dRowNew = dRowNew + 1: shNew.Cells(dRowNew, 1) = "3100 / 3107":
shNew.Cells(dRowNew, 2) = "KL7"
shNew.Cells(dRowNew, 6).FormulaR1C1 = "=SUMIF(C[-3],RC[-4],C)"
dRowNew = dRowNew + 1: shNew.Cells(dRowNew, 1) = "3100 / 3109":
shNew.Cells(dRowNew, 2) = "KET"
shNew.Cells(dRowNew, 6).FormulaR1C1 = "=SUMIF(C[-3],RC[-4],C)"

End Function
 

Lesen sie die antworten

#1 Winfried Sonntag [MVP]
05/11/2009 - 18:33 | Warnen spam
Marco schrieb:

Wir hatten ein VB Makro in Excel 2007 laufen, welches auf eine Access 2003
mdb Datenbank zugegriffen hat.
Jetzt wurde diese Datenbank ins ACCDB Format konvertiert und seit dem funzt
auch das Makro nicht mehr :-(

Ich hab mich bissi schlau gemacht und herausgefunden, dass es jetzt nicht
mehr die DAO3.6 als Library benötigt, sondern die ACEDAO, da nur die auf das
ACCDB Access Fileformat zugreifen kann.



Hmm, DAO 3.6 brauchst Du dann aber nicht mehr.

Hab die Library zusàtzlich zur DAO3.6 eingebunden, aber erhalten leider
jetzt dennoch einen Fehler und zwar bei diesem Befehl:



Zusàtzlich ist für Access IMHO nicht nötig.

If db Is Nothing Then Set db = OpenDatabase(sDBPath)

Was muss ich denn noch àndern, damit das Makro wieder làuft?



Ist die Fehlermeldung geheim? Nimm mal den Verweise auf DAO 3.6 raus und
probiers nochmal.

Servus
Winfried
Connect2WSUS: http://www.grurili.de/tools/Connect2WSUS.exe
GPO's: http://www.gruppenrichtlinien.de
Gruppenrichtlinien Mailingliste "gpupdate":
http://frickelsoft.net/cms/index.ph...ilingliste

Ähnliche fragen