Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.04.2024 20:05:21
28.04.2024 18:33:31
28.04.2024 18:25:12
28.04.2024 14:18:05
Anzeige
Archiv - Navigation
1916to1920
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA+SQL

VBA+SQL
01.02.2023 15:29:17
Peter
Hallo,
wer kann mir bei VBA mit SQL unter die Arme greifen? Ich soll ein bestehendes VBA Script soweit erweitern das über ein Button ein Status in einer SQL Tabelle gesetzt wird.
Der Status darf aber erst gesetzt werden, wenn folgendes wahr ist. Es muss eine Vorgangsnummer und Rechnungsnummer vorliegen. Dann soll geprüft werden ob es zu diesen Werten einen Auftrag gibt. Wenn dies wahr ist soll im Auftrag der Status gesetzt werden. Wer gern über den Code lesen möchte dem stelle ich diesem gern zur Verfügung.
Ich bin mit meinem Latein an der Stelle am Ende.
Danke

15
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA+SQL
01.02.2023 15:53:36
Yal
Hallo Peter,
der VBA-Skript bzw. die Datei (bereinigt von alles, was nicht im Netz gehört) mitzugeben, wäre für jede potentziellen Helfer ein guter Stütze, um einzuschätzen, ob er/sie helfen kann/will.
VG
Yal
AW: VBA+SQL
02.02.2023 07:15:37
Peter
Hallo Yal,
ich setz mal hier den Code rein:
Sub btn_StatusSetzen_Klicken()
Dim db_Status As Boolean
Const adOpenForwardOnly As Long = 0
'Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim db As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sConnect As String
Dim anzahlDS As Integer
Dim sSQL As String
Dim AuftragNr As Integer
Dim RechnungsNr As Integer
'Dim sSQLr As String
Dim filialeKurz
Dim diag As Object
Dim i As Integer
Set diag = DialogSheets("ReklaDialog")
If db_Status = False Then
    
    'sSQL = "SELECT KURZNAME FROM sani97.dbo.Filiale Order By FilialeNr "
    sSQL = "SELECT * FROM sani97.dbo.AuftragStatusZuordnung, Rechnungsposition" 'where 'AuftragNr' = 'RechnungNr'"  '* from AuftragStatusZuordnung, Rechnungsposition
    'AuftragNr, Vorgangnr anstatt *
    'sSQLr = "SELECT RechnungsNr FROM sani97.dbo.Rechnungsposition"
    
    sConnect = "DSN=sani97;" & _
    "UID=sani_user;" & _
    "PWD=sani97;" & _
    "IFSN=sani97sql;" & _
    "DB=sani97;" & _
    "applicationname=REKLA-EXCEL"
    
    'On Error GoTo Login_Error
        db.Open sConnect
        MsgBox sConnect
        db_Status = True
        
        'Erzeugen des Recordsets mit Schreibrechten
        MsgBox sSQL
        rs.Open sSQL, sConnect, adOpenUnspecified, adLockOptimistic, adCmdText
        'MsgBox sSQLr
'       rs.Open sSQLr, sConnect, adOpenUnspecified, adLockOptimistic, adCmdText
        'adOpenKeyset
        
        
        With rs
'        .MoveFirst
'       .Find Criteria:=KriteriumAngeben, SearchDirection:=adSearchForward
        
        If .Fields("RechnungNr") = True Then
            MsgBox "Ist vorhanden"
            Else
            If .Fields("AuftragNr") = True Then
            MsgBox "Ist vorhanden"
        End If
        
End If
        
'        .Find Criteria:="AuftragNr='Zahl'", SearchDirection:=adSearchForward
        
'        If .EOF = True Then
'            MsgBox "Kein passender Datensatz gefunden"
'        Else
'            .Fields(Spaltenname).Value = "Gewünschten Wert eintragen"
'           .Fields("AuftragNr").Value = "Gewünschten Wert eintragen"
'        End If
'        .Close   'schließt das Recordset
    End With
'        'Überprüfung ob Daten zurückgeliefert wurden
'        If Not rs.EOF And rs.RecordCount > 0 Then
'
'            filialeKurz = rs.GetRows
'            anzahlDS = rs.RecordCount
'
'            'MsgBox "Anzahl an Datensätzen = " & anzahlDS
'
'            With diag.DropDowns("ddn_auswahlFiliale")
'               .ListFillRange = anzahlDS - 1
'               .DropDownLines = 20
'                For i = 0 To anzahlDS - 1
'                    .AddItem CStr(filialeKurz(0, i))
'                    'ThisWorkbook.DialogSheets("ReklaDialog").DropDowns(2).AddItem (filialeKurz(0, 1))
'                Next
'             End With
            
'        Else
'            MsgBox "Keine Daten zu der Vorgangsnummer in SaniVision gefunden.", vbCritical
'            Exit Sub
        
        
        
        rs.Close
        db.Close
        Set rs = Nothing
        Set db = Nothing
        db_Status = False
    
        MsgBox "Es existiert bereits eine Datenbankverbindung zu SaniViison.", vbInformation
        
Exit Sub
Login_Error:
MsgBox "Error #: " & Err.Number & " : Es konnte keine Verbindung zu SaniVision hergestellt werden. Bitte wenden Sie sich an Ihren Administrator.", vbCritical
End If
End Sub

Anzeige
Noch offen
02.02.2023 09:30:36
Yal
Moin,
vergesse nicht den Haken bei "Frage noch offen" zu setzen, wenn Du zu deiner eigener Frage etwas beiträgst.
So sehen alle, dass die Frage nicht vollständig beantwortet wurde und können zur Hilfe beitragen.
VG
Yal
AW: VBA+SQL
02.02.2023 11:13:53
ChrisL
Hi
Da wir deine DB nicht kennen (welche Tabellen, Datenfelder gibt es), kann man nur raten. Entsprechend ist auch unklar, ob Nummer "nicht vorhanden" einem Null oder 0 entspricht.
Ich interpretiere:
Tabelle Rechungspostition
- Feld: RechnungNr
- Feld: Vorgangnr
Tabelle Auftragszuordnung
- Feld: AuftragNr
Die AuftragNr entspricht der RechnungNr.
Mit folgendem SQL Statement bekommst du ein Resultat, wenn ein Record wo sowohl RechnungNr und Vorgangnr gefüllt sind (und ungleich Zahl 0). Gleichzeitig entspricht die RechnungNr einer AuftragNr auf der anderen Tabelle.
SELECT AuftragsStatusZuordnung.AuftragNr
FROM Rechnungsposition INNER JOIN AuftragsStatusZuordnung ON Rechnungsposition.RechnungNr = AuftragsStatusZuordnung.AuftragNr
WHERE (((Rechnungsposition.RechnungNr) Is Not Null And (Rechnungsposition.RechnungNr)>0) AND ((Rechnungsposition.Vorgangnr) Is Not Null And (Rechnungsposition.Vorgangnr)>0))
Solche SQL-Statement baust du dir im Sinne einer Vorlage übrigens am einfachsten mittels Access zusammen.
cu
Chris
Anzeige
AW: VBA+SQL
02.02.2023 11:34:01
Peter
Hallo Chris.
erstmal vielen Dank für Deine Antwort. Es gibt die Tabelle/Datenbank AuftragStatusZuordnung und separat die Tabelle/Datenbank Rechnungsposition.
In der AuftragStatusZuordnung gibt es die Felder: AuftragNr als Zahl AuftragStatusNr als Zahl und AuftragStatProtTransNr als Zahl.
In der Rechnungsposition RechnungNr als Zahl VorgangNr als Zahl. Wenn nun RechnungNr + VorgangNr vorhanden sind soll geprüft werden ob es zu diesem Vorgang einen Auftrag/AuftragNr gibt. Wenn das der Fall ist soll ne MsgBox kommen und der Status gesetzt werden. Ich weiß das klingt alles ziemlich kompliziert als Außenstehender aber ich hoffe es ist nun etwas verständlicher rüber gekommen.
Anzeige
AW: VBA+SQL
02.02.2023 12:52:20
ChrisL
Hi
Ich habe jetzt zwar AuftragNr mit RechnungNr gleichgesetzt. Nach deiner neusten Beschreibung verstehe ich AuftragNr = VorgangNr, aber die Anpassung ist ja schnell gemacht. Ganz sicher bin ich mir aber weiterhin nicht, was der Schlüssel zwischen Rechnung und Auftrag ist.
Dein Code prüft ja bereits, ob ein Recordset vorhanden ist oder nicht. Somit müsste man dann nur noch das SQL-Statement anpassen.
Bitte beachte, dass dich das Forum vielleicht auf die richtige Fährte bringen kann, aber die Umsetzung müsste dann doch durch dich selber erfolgen.
cu
Chris
AW: VBA+SQL
02.02.2023 13:38:42
Peter
Chris auch Danke für diese Antwort.
Dann will ich Dir mal das ganze Projekt erklären. Mein Vorgänger hat dieses Script (ich hatte nur einen Teil davon hier gepostet) mal erstellt, welches folgendes macht.
Es wird in eine Eingabemaske eine Vorgangsnummer ein Euro Betrag und eine Rechnungsnummer eingegeben. Danach drückt man einen Button damit Daten aus unserer Warenwirtschaft eingelesen werden die dann in eine Exceltabelle geschrieben werden. Zugleich wird ein Formular (Reklamation) ausgedruckt. Wenn die Rekla abgeschlossen ist soll ich nun in die Eingabemaske einen Button hinzufügen Status setzen (erledigt) - bereits erledigt. Dieser Button soll nun abprüfen via Warenwirtschaft nach Eingabe der Vorgangsnummer des Betrages und der Rechnungsnummer ob es einen Auftrag dazu gibt. Wenn ja dann setze den Status in der Warenwirtschaft. Dazu gibt es die AuftragStatusZuordnung und die Rechnungsposition DB. Ich hoffe nun wird es sicher etwas klarer.
Anzeige
AW: VBA+SQL
02.02.2023 14:21:17
ChrisL
Hi
Sorry, dies ist mir alles zu abstrakt und vermutlich auch zu umfangreich. Ich klinke mich hier aus.
Tendenziell glaube ich, dass VBA-Basiswissen für ein solches Projekt (Wartung/Weiterentwicklung) nicht ausreicht. Entweder fuchst du dich selber in die Themen (VBA, ADODB, SQL) ein oder du suchst dir professionelle Hilfe.
Aber ich lasse die Frage natürlich offen.
cu
Chris
AW: VBA+SQL
02.02.2023 14:22:51
Peter
Chris trotzdem vielen Dank Dir.
AW: VBA+SQL
04.02.2023 13:01:18
Piet
Hallo Peter
heisser Tipp aus Ankara, lade doch mal eine Beispieldatei hoch, die dem Original entspricht. Alle Tabellen Namen und Spalten Überschriften wie im Original. Mit Fantasiedaten 2Frau Holl, böser Wolf" etc. Uns reichen zum verstehen des Tabellenaufbaus ca. 5-10 Zeilen, das reicht.
Kein Koleege wird, um ein Makro zu schreiben, die Datei selbst aufbauen. Haben wir ein Beispiel mit Lösung von Hand, ist es kein Thema sich Gedanken über ein Makro zu machen. Aber aufbauen - NO!
mfg Piet
Anzeige
AW: VBA+SQL
06.02.2023 07:55:28
Peter
Hallo Piet.
Danke für Deine Antwort. Hier nun die gewünschten Informationen.
Es geht um die Sub btn_setzen_klicken()
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ActiveSheet.EnableSelection = xlUnlockedCells
End Sub
Sub Rekla2021_Starten()
If Trim(ActiveWorkbook.Name) = "REKLA 2021.xls" Then
Dim db_Open As Boolean
db_Open = False

Felder_leeren
Setzen_DDN_AbweichFiliale
AuswahlFiliale_unterdruecken
AuswahlFiliale_fuellen db_Open

DialogSheets("ReklaDialog").Show

ActiveWorkbook.Save

ElseIf Trim(ActiveWorkbook.Name) = "REKLA 2021.xls" Then
MsgBox "Falsche Arbeitsmappe für diesen Button ausgewählt.", vbOKOnly

End If
End Sub Sub Blattschutz_aufheben()
ActiveSheet.Unprotect deinpasswort
End Sub Sub txf_vorgangsNr_BeiÄnderung()
PruefeObeineZahl
End Sub Sub txf_reklamBetrag_BeiÄnderung()
PruefeObeineZahl
End Sub Sub ddn_auswahlFiliale_BeiÄnderung()

End Sub Sub ddn_auswahlFiliale_Klicken()

End Sub Sub txf_rechnungsNr_BeiÄnderung()
PruefeObeineZahl
End Sub
Public Function bekommeBlattvomCodeName(CodeName As String, _
  Optional Sheet As Object, _
  Optional InWorkbook As Workbook) As Boolean
 
    If InWorkbook Is Nothing Then
        Set InWorkbook = ThisWorkbook
    End If
    
    For Each Sheet In InWorkbook.Sheets
        If StrComp(Sheet.Name, CodeName, vbTextCompare) = 0 Then
            bekommeBlattvomCodeName = True
            Exit For
        End If
    Next
End Function
Sub btn_DatenEinlesen_Klicken()
Dim db_Stat As Boolean
Dim diag As Object
Dim mydrop As Object
Dim mydrop1 As Object
Dim mylabel As Object
Dim mytxfvorgang As Object
Dim mytxfrechnung As Object
Dim myarray
Dim aktAbweichFiliale As Integer
Dim aktAuswahlFiliale As Integer
Dim NameAuswahlFiliale As String
Dim txf_vorgangsNr As Long
Dim txf_rechnungsNr As Variant
Dim abweichungFiliale As Integer

'Dim statussetzen As String 'Test
Set diag = DialogSheets("ReklaDialog")
Set mydrop = diag.DropDowns("ddn_abweichFiliale")
Set mydrop1 = diag.DropDowns("ddn_auswahlFiliale")
Set mytxfvorgang = diag.EditBoxes("txf_vorgangsNr")
Set mytxfrechnung = diag.EditBoxes("txf_rechnungsNr")

'Set statussetzen = diag.EditBoxes("txf_rechnungsNr") 'Test


abweichungFiliale = 0
aktAbweichFiliale = mydrop.ListIndex
aktAuswahlFiliale = mydrop1.ListIndex

If (mytxfvorgang.Text > "") Then
'txf_vorgangsNr = diag.EditBox("txf_vorgangsNr").Value
txf_vorgangsNr = CVar(mytxfvorgang.Text)
Else
MsgBox "Geben Sie bitte eine gültige Vorgangsnummer an.", vbInformation, "Fehler:"
Exit Sub
End If

If (mytxfrechnung.Text > "") Then
txf_rechnungsNr = CDec(mytxfrechnung.Text)
Else
MsgBox "Geben Sie bitte eine Rechnungsnummer an.", vbInformation, "Fehler:"
Exit Sub
End If

' Wenn das DropdownFeld "Auswahl Filiale" auf Nein gesetzt wurde
If (aktAbweichFiliale = 1) Then

abweichungFiliale = 1
FindeTabellenblatt db_Stat, NameAuswahlFiliale, abweichungFiliale, txf_vorgangsNr, txf_rechnungsNr

Else

NameAuswahlFiliale = mydrop1.List(aktAuswahlFiliale)
abweichungFiliale = 2
FindeTabellenblatt db_Stat, NameAuswahlFiliale, abweichungFiliale, txf_vorgangsNr, txf_rechnungsNr

End If
End Sub Sub btn_StatusSetzen_Klicken()
Dim db_Status As Boolean
Const adOpenForwardOnly As Long = 0
'Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim db As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sConnect As String
Dim anzahlDS As Integer
Dim sSQL As String
Dim AuftragNr As Integer
Dim RechnungNr As Integer
'Dim Rechnungsposition As Integer
'Dim sSQLr As String
'Dim filialeKurz
Dim diag As Object
Dim i As Integer
Set diag = DialogSheets("ReklaDialog")
If db_Status = False Then

'sSQL = "SELECT KURZNAME FROM sani97.dbo.Filiale Order By FilialeNr "
sSQL = "SELECT * FROM sani97.dbo.AuftragStatusZuordnung, Rechnungsposition" 'where 'AuftragNr' = 'RechnungNr'" '* from AuftragStatusZuordnung, Rechnungsposition
'sSQL = "SELECT * FROM sani97.dbo.AuftragStatusZuordnung JOIN AuftragNr where FROM sani97.dbo.Rechnungsposition"
'AuftragNr, Vorgangnr anstatt *
'sSQLr = "SELECT RechnungsNr FROM sani97.dbo.Rechnungsposition"
'sSQL = "SELECT AuftragNr FROM sani97.dbo.AuftragStatusZuordnung INNER JOIN AuftragsStatusZuordnung ON Rechnungsposition.RechnungNr = AuftragsStatusZuordnung.AuftragNr" WHERE (((Rechnungsposition.RechnungNr) Is Not Null And (Rechnungsposition.RechnungNr) > 0) And ((Rechnungsposition.Vorgangnr) Is Not Null And (Rechnungsposition.Vorgangnr) > 0))



sConnect = "DSN=sani97;" & _
"UID=sani_user;" & _
"PWD=sani97;" & _
"IFSN=sani97sql;" & _
"DB=sani97;" & _
"applicationname=REKLA-EXCEL"

'On Error GoTo Login_Error
db.Open sConnect
MsgBox sConnect
db_Status = True

'Erzeugen des Recordsets mit Schreibrechten
MsgBox sSQL
rs.Open sSQL, sConnect, adOpenUnspecified, adLockOptimistic, adCmdText
'MsgBox sSQLr
' rs.Open sSQLr, sConnect, adOpenUnspecified, adLockOptimistic, adCmdText
'adOpenKeyset


With rs
' .MoveFirst
' .Find Criteria:=KriteriumAngeben, SearchDirection:=adSearchForward

If .Fields("RechnungNr") = True Then
MsgBox "Ist vorhanden"
Else
If .Fields("AuftragNr") = True Then
MsgBox "Ist vorhanden"
End If

End If

' .Find Criteria:="AuftragNr='Zahl'", SearchDirection:=adSearchForward

' If .EOF = True Then
' MsgBox "Kein passender Datensatz gefunden"
' Else
' .Fields(Spaltenname).Value = "Gewünschten Wert eintragen"
' .Fields("AuftragNr").Value = "Gewünschten Wert eintragen"
' End If
' .Close 'schließt das Recordset
End With
' 'Überprüfung ob Daten zurückgeliefert wurden
' If Not rs.EOF And rs.RecordCount > 0 Then
'
' filialeKurz = rs.GetRows
' anzahlDS = rs.RecordCount
'
' 'MsgBox "Anzahl an Datensätzen = " & anzahlDS
'
' With diag.DropDowns("ddn_auswahlFiliale")
' .ListFillRange = anzahlDS - 1
' .DropDownLines = 20
' For i = 0 To anzahlDS - 1
' .AddItem CStr(filialeKurz(0, i))
' 'ThisWorkbook.DialogSheets("ReklaDialog").DropDowns(2).AddItem (filialeKurz(0, 1))
' Next
' End With

' Else
' MsgBox "Keine Daten zu der Vorgangsnummer in SaniVision gefunden.", vbCritical
' Exit Sub



rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
db_Status = False

MsgBox "Es existiert bereits eine Datenbankverbindung zu SaniViison.", vbInformation

Exit Sub
Login_Error:
MsgBox "Error #: " & Err.Number & " : Es konnte keine Verbindung zu SaniVision hergestellt werden. Bitte wenden Sie sich an Ihren Administrator.", vbCritical
End If
End Sub

Sub btn_ReklaErstellen_Klicken()
Dim b As Integer
For b = 1 To Sheets.Count
If (Sheets(b).Name > "ReklaDialog" And Sheets(b).Name > "WICHTIGE HINWEISE") Then
'MsgBox (Sheets(b).Name)
Call ErmittleZuDruckendeReklas(Sheets(b).Name)
Else
End If
Next b


'Call ErmittleZuDruckendeReklas("10")

MsgBox "Ihre Rechnungsreklamation wurden erfolgreich an den Drucker gesendet.", vbInformation
End Sub Sub ErmittleZuDruckendeReklas(wTBName As String)
Dim objwCell 'da stand nix
Dim objwrange As Range
Dim objwsheet As Worksheet
Dim objwworkbook As Workbook
Dim C As Integer


Dim wletztegefZeile As Integer
Dim woFilialeKurz As String
Dim woReklaNr As String
Dim woReklaBetrag As String
Dim woVorgangsNr As Long
Dim woKostentraeger As String
Dim woKunde As String
Dim woRechnungsNr As Variant
Dim woErstelltDatum As Date
Dim woRueckgabeDatum As Date

'Neue Zeilen

'Const MissingValue As Long = -10000000

'If IsNumeric(.Cells(C, 3).Value) Then
'woVorgangsNr = CLng(.Cells(C, 3).Value)
'Else
'woVorgangsNr = MissingValue
'End If
'Ende neue Zeilen


Set objwworkbook = Application.Workbooks("REKLA 2021.xls")
Set objwsheet = objwworkbook.Sheets(wTBName)

woFilialeKurz = ""
woReklaNr = 0
woReklaBetrag = 0 '"" '0
woVorgangsNr = 0 '"" '0
woKostentraeger = ""
woKunde = ""
woRechnungsNr = 0
woErstelltDatum = Empty
woRueckgabeDatum = Empty

'Hier wir die letzte beschriebene Zeile der Spalte A ermittelt
With Workbooks("REKLA 2021.xls").Worksheets(wTBName)
wletztegefZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
End With

'MsgBox "letzte, befüllte Zeille = " & wletztegefZeile

For C = 4 To wletztegefZeile

With Workbooks("REKLA 2021.xls").Worksheets(wTBName)

If Trim(.Cells(C, 1)) > "" Then

If (Trim(.Cells(C, 4)) > "x" And Trim(.Cells(C, 4)) > "X") Then

'MsgBox "noch nicht gedruckt!! Tabellenblatt = " & wTBName & " Zeile = " & c



woReklaNr = .Cells(3, 1).Value & .Cells(C, 1).Value
woReklaBetrag = FormatNumber(.Cells(C, 2).Value) 'Format(.Cells(C, 2).Value = Empty)

woVorgangsNr = .Cells(C, 3).Value

'Then woVorgangsNr = CLng(.Cells(C, 3).Value)
'Else woVorgangsNr = MissingValue End If


woKostentraeger = .Cells(C, 8).Value
woKunde = .Cells(C, 9).Value
woRechnungsNr = .Cells(C, 10).Value
woErstelltDatum = .Cells(C, 11).Value
woRueckgabeDatum = .Cells(C, 12).Value

woFilialeKurz = Filialbezeichnung_ermitteln(wTBName)

Call Word_Dokument_von_Excel_aus_steuern(woFilialeKurz, woReklaNr, woReklaBetrag, woVorgangsNr, woKostentraeger, woKunde, woRechnungsNr, woErstelltDatum, woRueckgabeDatum)
.Cells(C, 4).Value = "X"

ActiveWorkbook.Save

Else
'MsgBox "bereits gedruckt" & .Cells(c, 4) & " Zeile = " & c
End If

Else

End If

End With
Next C

End Sub Sub Word_Dokument_von_Excel_aus_steuern(wFilialeKurz As String, _
wReklaNr As String, _
wReklaBetrag As String, _
wVorgangsNr As Long, _
wKostentraeger As String, _
wKunde As String, _
wRechnungsNr As Variant, _
wErstelltDatum As Date, _
wRueckgabeDatum As Date)
Dim myWord, objWW, ws As Object
Dim strWordDokument As String
Dim sDruckerAktuell As String
'strWordDokument = "C:\temp\BL-1100581-Rechnungsrekla.dotx"
strWordDokument = "O:\Bereiche\Verwaltung\Debitoren\Rekla\Formular\BL-1100581-Rechnungsrekla.dotx"
'Fehlerroutine für die Objectabfrage aktivieren
On Error Resume Next
'Abfragen einer besthenden WORD-Instanz um wiederholtes starten zu verhindern
Set myWord = GetObject("Word.Application")
If Err.Number > 0 Then
'Fehlervariable leeren wenn Instanz noch nicht besteht
Err.Clear
'Zuweisung der Instanz
Set myWord = CreateObject("Word.Application")
'Instanz öffnen
'Um das ganze etwas im Hintergrund laufen zu lassen
'kann man den Status "wdWindowStateMinimize" verwenden
'myWord.Visible = False: objWW.WindowState = wdWindowStateMinimize
myWord.Visible = False
Else
'Instanz besteht bereits
myWord.Activate
'Instanz in der Vordergrund bringen oder
'mit "wdWindowStateMinimize" im Hintergrund ausführen
'mit "wdWindowStateMaximize" nicht im Hintergrund ausführen
myWord.Visible = False
End If
'Hier muss der Dateiname stehen der verwendet werden soll
'Es sollte aber eine Dokumentvorlage verwendet werden
'um keine Änderungen an den Textmarken beim einfügen zu verursachen
'myWord.Documents.Open (strWordDokument)
myWord.Documents.Add (strWordDokument)
'Die Textmarken "a1, a2, a3" müssen im Dokument bereits bestehen
'Dann werden nach dem öffnen des Dokuments die Werte von Tabelle1
'A1, B1 und C1 in die jeweiligen Textmarken geschrieben
'If myWord.ActiveDocument.Bookmarks.Exists("wFiliale") = True Then
' 'myWord.ActiveDocument.Bookmarks("wFiliale").Select
' 'myWord.ActiveDocument.Bookmarks("wFiliale").Range.Text = Worksheets("10").Range("B5")
' myWord.ActiveDocument.Bookmarks("wFiliale").Range.Text = wFiliale
'End If
'With myWord.ActiveDocument.Bookmarks
' If .Exists("wReklaNr") = True Then
' Set ReklaRange = ActiveDocument.Bookmarks("wReklaNr").Range
' ReklaRange.Text = wReklaNr
' 'myWord.ActiveDocument.Bookmarks("wReklaNr").Range.Text = wReklaNr
' End If
'
' ' Textmarke recykeln
' .Add Range:=wReklaNr, Name:="wReklaNr"
'End With
With myWord.ActiveDocument
If .Bookmarks.Exists("wFiliale") = True Then
.Bookmarks("wFiliale").Range.Text = wFilialeKurz
End If
If .Bookmarks.Exists("wReklaNr") = True Then
.Bookmarks("wReklaNr").Range.Text = wReklaNr
End If
If .Bookmarks.Exists("wKostentraeger") = True Then
.Bookmarks("wKostentraeger").Range.Text = wKostentraeger
End If
If .Bookmarks.Exists("wKunde") = True Then
.Bookmarks("wKunde").Range.Text = wKunde
End If
If .Bookmarks.Exists("wReklaBetrag") = True Then
.Bookmarks("wReklaBetrag").Range.Text = wReklaBetrag
End If
If .Bookmarks.Exists("wRechnungsNr") = True Then
.Bookmarks("wRechnungsNr").Range.Text = wRechnungsNr
End If

If .Bookmarks.Exists("wVorgangsNr") = True Then
.Bookmarks("wVorgangsNr").Range.Text = wVorgangsNr
End If
If .Bookmarks.Exists("wErstelltDatum") = True Then
.Bookmarks("wErstelltDatum").Range.Text = wErstelltDatum
End If
If .Bookmarks.Exists("wRueckgabeDatum") = True Then
.Bookmarks("wRueckgabeDatum").Range.Text = wRueckgabeDatum
End If

'Felder auf Formular-Kopie
If .Bookmarks.Exists("kwFiliale") = True Then
.Bookmarks("kwFiliale").Range.Text = wFilialeKurz
End If
If .Bookmarks.Exists("kwReklaNr") = True Then
.Bookmarks("kwReklaNr").Range.Text = wReklaNr
End If
If .Bookmarks.Exists("kwKostentraeger") = True Then
.Bookmarks("kwKostentraeger").Range.Text = wKostentraeger
End If
If .Bookmarks.Exists("kwKunde") = True Then
.Bookmarks("kwKunde").Range.Text = wKunde
End If
If .Bookmarks.Exists("kwReklaBetrag") = True Then
.Bookmarks("kwReklaBetrag").Range.Text = wReklaBetrag
End If
If .Bookmarks.Exists("kwRechnungsNr") = True Then
.Bookmarks("kwRechnungsNr").Range.Text = wRechnungsNr
End If

If .Bookmarks.Exists("kwVorgangsNr") = True Then
.Bookmarks("kwVorgangsNr").Range.Text = wVorgangsNr
End If
If .Bookmarks.Exists("kwErstelltDatum") = True Then
.Bookmarks("kwErstelltDatum").Range.Text = wErstelltDatum
End If
If .Bookmarks.Exists("kwRueckgabeDatum") = True Then
.Bookmarks("kwRueckgabeDatum").Range.Text = wRueckgabeDatum
End If
End With

'For Each ws In Worksheets
' MsgBox ws.Name
'Next ws
'Aktuellen Standarddrucker merken
sDruckerAktuell = Application.ActivePrinter
MsgBox "Aktiver Drucker = " & sDruckerAktuell
myWord.ActivePrinter = "\\server-28\Canon Farbe"
'myWord.ActiveDocument.msoBlackWhiteBlack = False
'MsgBox "Farbeinstellungen des Druckers: " & myWord.ActivePrinter.ColorMode
'myWord.ActivePrinter.ColorMode = Color
'Das aktive WordDokument drucken
myWord.ActiveDocument.PrintOut
'Den vorherigen Standarddrucker wieder setzen
myWord.ActivePrinter = "\\server-28\Canon"
'Dokument schliessen ohne speichern
myWord.ActiveDocument.Close savechanges:=False
'myWord.ActiveDocument.Close savechanges:=True
'Speichern mit fixem Namen
'myWord.ActiveDocument.SaveAs Filename:="DokumentName", FileFormat:=wdFormatDocument
'Speichern mit Variable
'myWord.ActiveDocument.SaveAs Filename:=Variable, FileFormat:=wdFormatDocument
'WORD-Instanz schliessen
myWord.Application.Quit (True)
'Variable leeren
Set myWord = Nothing
End Sub '-------------------------------------------------
'Sub Test2()
'
''Im Excel VBA-Editor für die Datei mit diesem Makro unter Extras-Verweise _
'den Verweis auf die Microsoft Word x.y Object Library aktivieren!!
'Dim WinWord, WinDoc As Word.Document, docSerienbrief As Word.Document
'Dim sFile As String
'Dim strCon As String
'Dim strWOrdvorlage As String
'Dim strDatenQuelle As String
'
'strWOrdvorlage = "C:\Users\Noffke\Desktop\BL-1100581-Rechnungsrekla.docx"
'strDatenQuelle = "C:\Users\Noffke\Desktop\REKLA 2015.xls"
'
'sFile = strWOrdvorlage
'Set WinWord = CreateObject("Word.Application")
'
'With WinWord
' .Visible = True
' 'Vorlagedatei öffnen
' Set WinDoc = .Documents.Open(sFile)
' With WinDoc
' With .MailMerge
' 'Datenquelle öffnen
' .OpenDataSource Name:=strDatenQuelle, _
' Connection:="Provider=Microsoft.Jet.OLEDB.4.0;" _
' & "Data Source=" & strDatenQuelle & ";" _
' & "Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";" _
' & "Jet OLEDB:Engine ", _
' SQLStatement:="SELECT * FROM `Tabelle1$`"
' 'Serienbrief mit allen Daten in neuem Dokument erstellen
' .Destination = wdSendToNewDocument
' .SuppressBlankLines = True
' With .DataSource
' .FirstRecord = wdDefaultFirstRecord
' .LastRecord = wdDefaultLastRecord
' End With
' .Execute Pause:=False
'
' Set docSerienbrief = WinWord.ActiveDocument
' 'Datenquelle wieder schliessen
' .DataSource.Close
' End With
'
' 'Vorlagedatei wieder schliessen
' .Close savechanges:=False
' End With
'
' 'Serienbrief - Drucken - Seitenvorschau
' docSerienbrief.Application.WindowState = wdWindowStateMinimize
' If MsgBox("Serienbrief Drucken ?", vbYesNo + vbQuestion, _
' "Serienbrief-Erstellung - Drucken - Seitenvorschau") = vbYes Then
' docSerienbrief.Application.WindowState = wdWindowStateMaximize
' docSerienbrief.PrintPreview
' ' docSerienbrief.PrintOut
' End If
'
' 'Serienbrief - Speichern
' docSerienbrief.Application.WindowState = wdWindowStateMinimize
' If MsgBox("Serienbrief Speichern ?", vbYesNo + vbQuestion, _
' "Serienbrief-Erstellung-Speicehrn") = vbYes Then
' docSerienbrief.Application.WindowState = wdWindowStateMaximize
' docSerienbrief.Application.Dialogs(wdDialogFileSaveAs).Show
' End If
'
' docSerienbrief.Application.WindowState = wdWindowStateMaximize
'End With
'
'Set docSerienbrief = Nothing
'Set WinWord = Nothing
'Set WinDoc = Nothing
'
'End Sub '-----------------------------------------------------------------------
Sub btn_Abbrechen_Klicken()
End Sub Sub Felder_leeren()
ThisWorkbook.DialogSheets("ReklaDialog").EditBoxes("txf_vorgangsNr").Text = ""
ThisWorkbook.DialogSheets("ReklaDialog").EditBoxes("txf_reklamBetrag").Text = ""
ThisWorkbook.DialogSheets("ReklaDialog").EditBoxes("txf_rechnungsNr").Text = ""
ThisWorkbook.DialogSheets("ReklaDialog").DropDowns("ddn_auswahlFiliale").List = ""
End Sub Sub ddn_abweichFiliale_BeiÄnderung()
Dim diag As Object
Dim mydrop As Object
Dim mydrop1 As Object
Dim mylabel As Object
Dim myarray
Dim aktAbweichFiliale As Integer
Set diag = DialogSheets("ReklaDialog")
Set mydrop = diag.DropDowns("ddn_abweichFiliale")
Set mydrop1 = diag.DropDowns("ddn_auswahlFiliale")
Set mylabel = diag.Labels("Bezeichnung 7")
aktAbweichFiliale = mydrop.ListIndex

' Wenn das DropdownFeld "Auswahl Filiale" auf Nein gesetzt wurde
If (aktAbweichFiliale = 1) Then

mydrop1.Visible = False
mylabel.Visible = False

Else
mydrop1.Visible = True
mylabel.Visible = True

End If
End Sub Sub PruefeObeineZahl()
Dim sZuPruefendesEingabefeld As EditBox
Set sZuPruefendesEingabefeld = ActiveDialog.EditBoxes(Application.Caller)
If Not IsNumeric(sZuPruefendesEingabefeld.Text) And sZuPruefendesEingabefeld.Text > "" Then
Beep
MsgBox "Buchstaben oder Sonderzeichen sind nicht erlaubt !", vbInformation, "Fehler:"
sZuPruefendesEingabefeld.Text = Left(sZuPruefendesEingabefeld.Text, _
Len(sZuPruefendesEingabefeld.Text) - 1)
SendKeys "{end}"
End If
End Sub Sub Setzen_DDN_AbweichFiliale()
Dim diag As Object
'Dim mylist As Object
Dim mydrop As Object
Dim myarray
Dim x As Integer
Set diag = DialogSheets("ReklaDialog")
'Set mylist = diag.ListBoxes("List Box 4")
Set mydrop = diag.DropDowns("ddn_abweichFiliale")
'mylist.RemoveAllItems
mydrop.RemoveAllItems
myarray = Array("Nein", "Ja")
For x = 0 To 1
'mylist.AddItem myarray(x)
mydrop.AddItem myarray(x)
Next x

mydrop.ListIndex = 1

End Sub Sub AuswahlFiliale_unterdruecken()
Dim diag As Object
Dim mydrop As Object
Dim mylabel As Object
Set diag = DialogSheets("ReklaDialog")
Set mydrop = diag.DropDowns("ddn_auswahlFiliale")
Set mylabel = diag.Labels("Bezeichnung 7")


mydrop.Visible = False
mylabel.Visible = False
End Sub Function Filialbezeichnung_ermitteln(dbTBName As String)
Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim db1 As New ADODB.Connection
Dim rs4 As New ADODB.Recordset
Dim db_Status As Boolean
Dim sConnect4 As String
Dim sSQL4 As String
Dim rsFilialeKurz
Dim dbFilialeKurz As String
Dim dbFiliale As Integer
db_Status = False
If db_Status = False Then
dbFiliale = CInt(dbTBName)

sSQL4 = "SELECT KURZNAME FROM sani97.dbo.Filiale WHERE FilialeNr = " & dbFiliale

sConnect4 = "DSN=sani97;" & _
"UID=sani_user;" & _
"PWD=sani97;" & _
"IFSN=sani97sql;" & _
"DB=sani97;" & _
"applicationname=REKLA-EXCEL"
'On Error GoTo Login_Error
db1.Open sConnect4
db_Status = True

'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs4.Open sSQL4, sConnect4, adOpenKeyset, adLockReadOnly, adCmdText
'Überprüfung ob Daten zurückgeliefert wurden
If Not rs4.EOF And rs4.RecordCount > 0 Then

rsFilialeKurz = rs4.GetRows
dbFilialeKurz = rsFilialeKurz(0, 0)

Filialbezeichnung_ermitteln = dbFilialeKurz
Exit Function

Else
MsgBox "Die Filale wurde nicht in SaniVision gefunden.", vbCritical
Filialbezeichnung_ermitteln ""
Exit Function
End If
rs4.Close
db1.Close
Set rs4 = Nothing
Set db1 = Nothing
db_Status = False
Else

MsgBox "Es existiert bereits eine Datenbankverbindung zu SaniViison.", vbInformation
Exit Function
End If
Exit Function
Login_Error:
MsgBox "Error #: " & Err.Number & " : Es konnte keine Verbindung zu SaniVision hergestellt werden. Bitte wenden Sie sich an Ihren Administrator.", vbCritical

End Function Sub AuswahlFiliale_fuellen(db_Status As Boolean)
Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim db As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sConnect As String
Dim anzahlDS As Integer
Dim sSQL As String
Dim filialeKurz
Dim diag As Object
Dim i As Integer
Set diag = DialogSheets("ReklaDialog")
If db_Status = False Then

sSQL = "SELECT KURZNAME FROM sani97.dbo.Filiale Order By FilialeNr "

sConnect = "DSN=sani97;" & _
"UID=sani_user;" & _
"PWD=sani97;" & _
"IFSN=sani97sql;" & _
"DB=sani97;" & _
"applicationname=REKLA-EXCEL"
'On Error GoTo Login_Error
db.Open sConnect
db_Status = True

'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs.Open sSQL, sConnect, adOpenKeyset, adLockReadOnly, adCmdText
'Überprüfung ob Daten zurückgeliefert wurden
If Not rs.EOF And rs.RecordCount > 0 Then

filialeKurz = rs.GetRows
anzahlDS = rs.RecordCount

'MsgBox "Anzahl an Datensätzen = " & anzahlDS

With diag.DropDowns("ddn_auswahlFiliale")
.ListFillRange = anzahlDS - 1
.DropDownLines = 20
For i = 0 To anzahlDS - 1
.AddItem CStr(filialeKurz(0, i))
'ThisWorkbook.DialogSheets("ReklaDialog").DropDowns(2).AddItem (filialeKurz(0, 1))
Next
End With

Else
MsgBox "Keine Daten zu der Vorgangsnumemr in SaniVision gefunden.", vbCritical
Exit Sub
End If
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
db_Status = False
Else

MsgBox "Es existiert bereits eine Datenbankverbindung zu SaniViison.", vbInformation
Exit Sub
End If
Exit Sub
Login_Error:
MsgBox "Error #: " & Err.Number & " : Es konnte keine Verbindung zu SaniVision hergestellt werden. Bitte wenden Sie sich an Ihren Administrator.", vbCritical

End Sub Sub FindeTabellenblatt(db_Status As Boolean, NameAuswlFil As String, abwFil As Integer, vorgangsNr As Long, RechnungsNr As Variant)
Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim db As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim rs1 As New ADODB.Recordset
Dim rs2 As New ADODB.Recordset
Dim rs3 As New ADODB.Recordset
Dim sConnect As String
Dim anzahlDS As Integer
Dim sSQL As String
Dim sSQL1 As String
Dim sSQL2 As String
Dim sSQL3 As String
Dim rsfilialeNr
Dim rsabwfilialeNr
Dim rsKunde
Dim rsKTR
Dim filialeNr As String
Dim abwfilialeNr As String
Dim kunde As String
Dim ktr As String
Dim Filiale_vorhanden As Boolean
Dim diag As Object
Dim i As Integer
Set diag = DialogSheets("ReklaDialog")
' Es soll eine abweichende Filiale zum Vorgang genommen werden
sSQL = "SELECT FilialeNr FROM sani97.dbo.Filiale WHERE KURZNAME = '" & NameAuswlFil & "' "
' Es soll die Filiale des Vorgangs genommen werden
sSQL1 = "SELECT FilialeNr FROM sani97.dbo.Vorgang WHERE VorgangNr = " & vorgangsNr

' Ermitelt den Kunden zum Vorgang
sSQL2 = "SELECT NAME1, NAME2, KundenNr FROM sani97.dbo.Kunden WHERE KundenNr = (SELECT KundenNr FROM sani97.dbo.Vorgang WHERE dbo.Vorgang.VorgangNr = " & vorgangsNr & ")"
'sSQL2 = "SELECT kd.NAME2, kd.NAME1, ktr.NAME1, ktr.NAME2 FROM sani97.dbo.Kunden kd, sani97.dbo.Kostentraeger ktr WHERE kd.KundenNr = (SELECT vor.KundenNr FROM sani97.dbo.Vorgang vor WHERE vor.VorgangNr = " & vorgangsNr & ") AND kd.KKNr = ktr.KTNr"
' Ermittlung des Kostenträgers zur Rechnungsnummer
sSQL3 = "SELECT ktr.NAME1, ktr.NAME2 FROM sani97.dbo.Rechnung rg, sani97.dbo.Kostentraeger ktr WHERE rg.KTNr = ktr.KTNr AND rg.RechnungNr = " & RechnungsNr
anzahlDS = 0
If db_Status = False Then
If NameAuswlFil > "" Then

sConnect = "DSN=sani97;" & _
"UID=sani_user;" & _
"PWD=sani97;" & _
"IFSN=sani97sql;" & _
"DB=sani97;" & _
"applicationname=REKLA-EXCEL"
'On Error GoTo Login_Error
db.Open sConnect
db_Status = True


'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs.Open sSQL, sConnect, adOpenKeyset, adLockReadOnly, adCmdText


' Überprüfung ob Daten zurückgeliefert wurden
If Not rs.EOF And rs.RecordCount > 0 Then

rsfilialeNr = rs.GetRows
filialeNr = rsfilialeNr(0, 0)

Filiale_vorhanden = istTabellenblatt_vorhanden(filialeNr)

If Filiale_vorhanden = True Then

'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs1.Open sSQL1, sConnect, adOpenKeyset, adLockReadOnly, adCmdText

' Überprüfung ob Daten zurückgeliefert wurden
If Not rs1.EOF And rs1.RecordCount > 0 Then

rsabwfilialeNr = rs1.GetRows
anzahlDS = rs1.RecordCount

abwfilialeNr = "(" & rsabwfilialeNr(0, 0) & ")"

'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs2.Open sSQL2, sConnect, adOpenKeyset, adLockReadOnly, adCmdText

If Not rs2.EOF And rs2.RecordCount > 0 Then

rsKunde = rs2.GetRows
kunde = rsKunde(1, 0) & ", " & rsKunde(0, 0) & " (" & rsKunde(2, 0) & ")"

'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs3.Open sSQL3, sConnect, adOpenKeyset, adLockReadOnly, adCmdText

If Not rs3.EOF And rs3.RecordCount > 0 Then

rsKTR = rs3.GetRows
ktr = rsKTR(0, 0) & " " & rsKTR(1, 0)

TabellenblattFilaleBearbeiten filialeNr, vorgangsNr, abwfilialeNr, RechnungsNr, kunde, ktr
'Sheets(filialeNr(0, 0)).Select

Else

MsgBox "Es wurde kein Kostenträger zur Rechnung " & RechnungsNr & " gefunden (evtl. falsche RechnungsNr). Bitte in SaniVision überprüfen.", vbInformation

End If

rs3.Close

Else

MsgBox "Es wurde kein Kunde zu diesem Vorgang gefunden. Bitte in SaniVision überprüfen.", vbInformation
rs2.Close

End If

rs2.Close

Else

MsgBox "Die abweichenden Filiale " & abwfilialeNr & " wurde in SaniVision nicht gefunden.", vbInformation

End If

Else

MsgBox "Für die Filiale " & filialeNr & " ist noch kein Tabellenblatt angelegt. Bitte anlegen, damit dieses gefüllt werden kann.", vbInformation
Exit Sub
End If

Else

MsgBox "Die Filiale " & filialeNr & " wurde in SaniVision nicht gefunden.", vbInformation

End If

rs1.Close

Else

sConnect = "DSN=sani97;" & _
"UID=sani_user;" & _
"PWD=sani97;" & _
"IFSN=sani97sql;" & _
"DB=sani97;" & _
"applicationname=REKLA-EXCEL"
'On Error GoTo Login_Error
db.Open sConnect
db_Status = True

'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs1.Open sSQL1, sConnect, adOpenKeyset, adLockReadOnly, adCmdText
' Überprüfung ob Daten zurückgeliefert wurden
If Not rs1.EOF And rs1.RecordCount > 0 Then

rsfilialeNr = rs1.GetRows

filialeNr = rsfilialeNr(0, 0)
abwfilialeNr = ""

Filiale_vorhanden = istTabellenblatt_vorhanden(filialeNr)

If Filiale_vorhanden = True Then

'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs2.Open sSQL2, sConnect, adOpenKeyset, adLockReadOnly, adCmdText

If Not rs2.EOF And rs2.RecordCount > 0 Then

rsKunde = rs2.GetRows
kunde = rsKunde(1, 0) & ", " & rsKunde(0, 0) & " (" & rsKunde(2, 0) & ")"

'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs3.Open sSQL3, sConnect, adOpenKeyset, adLockReadOnly, adCmdText

If Not rs3.EOF And rs3.RecordCount > 0 Then

rsKTR = rs3.GetRows
ktr = rsKTR(0, 0) & " " & rsKTR(1, 0)

TabellenblattFilaleBearbeiten filialeNr, vorgangsNr, abwfilialeNr, RechnungsNr, kunde, ktr
'Sheets(filialeNr(0, 0)).Select

Else
MsgBox "Es wurde kein Kostenträger zur Rechnung " & RechnungsNr & " gefunden (evtl. falsche RechnungsNr). Bitte in SaniVision überprüfen.", vbInformation

End If

rs3.Close

Else

MsgBox "Es wurde kein Kunde zu diesem Vorgang gefunden. Bitte in SaniVision überprüfen.", vbInformation

End If

rs2.Close

Else

MsgBox "Für die Filiale " & filialeNr & " ist noch kein Tabellenblatt angelegt. Bitte anlegen, damit dieses gefüllt werden kann.", vbInformation

End If

'Sheets(filialeNr(0, 0)).Select

Else
MsgBox "Keine Daten zu der Vorgangsnummer in SaniVision gefunden.", vbCritical
End If

rs1.Close

End If
db.Close
Set rs = Nothing
Set rs1 = Nothing
Set rs2 = Nothing
Set db = Nothing
db_Status = False
Else

MsgBox "Es existiert bereits eine Datenbankverbindung zu SaniViison. Bitte beenden Sie Excel und starten Sie es neu.", vbInformation
Exit Sub
End If
Exit Sub
Login_Error:
MsgBox "Error #: " & Err.Number & " : Es konnte keine Verbindung zu SaniVision hergestellt werden. Bitte wenden Sie sich an Ihren Administrator.", vbCritical
End Sub Function istTabellenblatt_vorhanden(TBvorhName As String)
Dim a As Integer
For a = 1 To Sheets.Count
If Sheets(a).Name = TBvorhName Then
istTabellenblatt_vorhanden = True
Exit Function
End If
Next a
istTabellenblatt_vorhanden = False
'Sheets("Muster").Select
'Sheets("Muster").Copy Before:=Sheets(6)
'ActiveSheet.Name = "Jahr"
End Function Sub TabellenblattFilaleBearbeiten(TBName As String, TBVorgangsNr As Long, abwTBName As String, TBRechnungsNr As Variant, TBKunde As String, TBKTR As String)
Dim objCell
Dim objrange As Range
Dim objsheet As Worksheet
Dim objworkbook As Workbook

Set objworkbook = Application.Workbooks("REKLA 2021.xls")
Set objsheet = objworkbook.Sheets(TBName)

Dim diag As Object
Dim mytxfreklamBetrag As Object

Dim letztegefZeile As Integer
Dim letzteReklaNr As String
Dim intletzteReklaNr As Integer
Dim naechsteReklaNr As String
Dim intnaechsteReklaNr As Integer
Dim reklaBetrag As Currency
Dim i As Integer

Set diag = DialogSheets("ReklaDialog")
Set mytxfreklamBetrag = diag.EditBoxes("txf_reklamBetrag")

If bekommeBlattvomCodeName(TBName, objsheet, Workbooks("REKLA 2021.xls")) Then

'MsgBox "WS CodeName = " & ws.CodeName & " WS Name = " & ws.Name
'Sheets(TBName).Select

'Hier wir die letzte beschriebene Zeile der Spalte A ermittelt
'letztegefZeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
With Workbooks("REKLA 2021.xls").Worksheets(TBName)
letztegefZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
letzteReklaNr = .Cells(letztegefZeile, 1)
End With


If letztegefZeile = 3 Then

naechsteReklaNr = abwTBName & "/001"

Else
'MsgBox "letzte, befüllte Zelle = " & letztegefZeile
'MsgBox "letzte Rekla-Nr. = " & letzteReklaNr
intletzteReklaNr = CInt(Right(Trim(letzteReklaNr), 3))
intnaechsteReklaNr = intletzteReklaNr + 1
naechsteReklaNr = abwTBName & "/" & Format(intnaechsteReklaNr, "000")

End If

If (mytxfreklamBetrag.Text > "") Then

reklaBetrag = CCur(mytxfreklamBetrag.Text)
Else

MsgBox "Bitte geben Sie den zu reklamierenden Betrag ein.", vbInformation
Exit Sub

End If


'MsgBox "naechste Rekla-Nr. = " & naechsteReklaNr

With Workbooks("REKLA 2021.xls").Worksheets(TBName)
.Cells(letztegefZeile + 1, 1).Value = naechsteReklaNr
.Cells(letztegefZeile + 1, 2).Value = reklaBetrag
.Cells(letztegefZeile + 1, 3).Value = TBVorgangsNr
.Cells(letztegefZeile + 1, 8).Value = TBKTR
.Cells(letztegefZeile + 1, 9).Value = TBKunde
.Cells(letztegefZeile + 1, 10).Value = TBRechnungsNr
.Cells(letztegefZeile + 1, 11).Value = Date
.Cells(letztegefZeile + 1, 12).Value = DateSerial(Year(Date), Month(Date) + 1, Day(Date))

End With

ActiveWorkbook.RefreshAll
ActiveWorkbook.Save

'Workbooks("REKLA 2015.xls").Worksheets(TBName).Cells(letztegefZeile + 1, 1).Value = naechsteReklaNr

Else

MsgBox "Das Arbeitsblatt wurde nicht in der Arbeitsmappe gefunden.", vbInformation

End If

End Sub
Anzeige
AW: VBA+SQL
07.02.2023 16:11:23
Oberschlumpf
und bitte WO ist per Upload die Bsp-Datei mit Bsp-Daten mit dem ganzen Code?
AW: VBA+SQL
06.02.2023 11:41:06
Piet
Hallo Peter
du meine Güte, das ist ja ein Monster Code. Da gibt es eine Menge Befehle die ich mit meinem bescheidenen VBA Wissen nicht kenne. Sorry, da fehlt mir schlicht und einfach der Durchblick.
Ich helfe gerne, aber mein Excel Wissen aus der Excel 5.0/97 Zeit hat seine Grenzen.
mfg Piet
AW: VBA+SQL
06.02.2023 11:53:17
Peter
Piet auch Dir Danke

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige