PDA

Vollständige Version anzeigen : Bräuchte jemanden der mir dringend Codes erklären kann


chfu3
27.06.2014, 15:12
Hallo,

ich hab mit Hilfe ein Richtig gutes Programm auf die beine gestellt die ich zur Prüfung verteidigen muss. und das Morgen:(

kann mir jemand helfen die Codes zu erklären? ich bin noch nicht so firm in VBA und mach das gerade so das erste mal richtig.

Ich muss morgen wissen was in den ganzen codes genau passiert.

hoffe es kann mir da jemand helfen! bin echt verzweifelt.

gruß Chris

MWOnline
27.06.2014, 15:38
Hallo,

Bei der kurzen Zeit hilft da nur die Helfer direkt zu Fragen, die Dir geholfen haben das Projekt zu realisieren. Denn alle anderen müssen sich erstmal einlesen und je nach Umfang dann noch erklären und das bis Morgen ist etwas eng...

Beste Grüße und viel Erfolg
Marc

chfu3
27.06.2014, 15:44
hey

er ist gerade nicht erreichbar das ist leider das Problem. wenn es jemand probieren würde wäre mir schon riesig geholfen:(

MWOnline
27.06.2014, 16:03
Hi,

wenn Dir hier im Forum geholfen werden soll, musst Du auch den Quelltext hochladen und Deine dazugehörigen Fragen aufschreiben, wie sollen wir sonst helfen ? :D

Beste Grüße
Marc

chfu3
27.06.2014, 16:26
Hier mal ein paar Codes. ich kann auch eine Datei schicken wo die funktion besser zu erkennen ist.

Ich weiß zwar was im Programm funktioniert nur die einzellnen Funktion was sie genau machen ist mir unbekannt und bin da noch nicht richtig drin.


1.Code

Private Sub TextBox12_Change() ' GIS Anlagentyp 2
Dim WS As Worksheet

If TextBox12 = "" Then
ListBox2.Visible = False ' wenn die textbox leer ist dann soll die Listbox ausgeblendet sein.

Else
ListBox2.Visible = True

End If

Me.ListBox2.Clear
If Trim(Me.TextBox12) = "" Then Exit Sub
For Each WS In ThisWorkbook.Worksheets
If InStr(1, WS.Name, "Checkliste", 1) <> 0 Then
If InStr(1, Left(WS.Name, Len(WS.Name) - 7) & Right(WS.Name, 1), Me.TextBox12.Text, 1) <> 0 Then
Me.ListBox2.AddItem WS.Name
End If
End If

If InStr(1, WS.Name, Me.TextBox12.Text, 1) <> 0 Then
Me.ListBox2.AddItem WS.Name
End If
Next WS
End Sub

Hier gehts mir um den rot markierten bereich. dort wird eine Listbox mit Tabellenblättern gefüllt die ich auswählen kann

2. Code

Private Sub CommandButton4_Click() ' Prüfscheine erstellen und speichern
Dim i As Integer, Ordnerpfad As String, Gesamtpfad As String, Weitermachen As Boolean, Liste As Variant, x As Integer, n As Integer


If Listbox_angewählt(Me.ListBox1) = False And Listbox_angewählt(Me.ListBox2) = False Then Exit Sub
If Trim(Me.TextBox1) = "" Or Trim(Me.TextBox3) = "" Or Trim(Me.TextBox4) = "" Then Exit Sub

ReDim Liste(x)

With Me.ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
Weitermachen = True
For n = LBound(Liste) To UBound(Liste)
If LCase(Liste(n)) = LCase(.List(i)) Then GoTo Weiter1
Next n
ReDim Preserve Liste(x)
Liste(x) = .List(i): x = x + 1
Weiter1:
End If
Next i
End With

With Me.ListBox2
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
Weitermachen = True
For n = LBound(Liste) To UBound(Liste)
If LCase(Liste(n)) = LCase(.List(i)) Then GoTo Weiter2
Next n
ReDim Preserve Liste(x)
Liste(x) = .List(i): x = x + 1
Weiter2:
End If
Next i
End With

If Weitermachen = False Then Exit Sub

Ordnerpfad = Ordnergrundpfad & Trim(Me.TextBox1) & "\" & Trim(Me.TextBox3) & "\" & Trim(Me.TextBox4)
Call Ordner_erstellen(Ordnerpfad)

Application.ScreenUpdating = False
For i = LBound(Liste) To UBound(Liste)
Gesamtpfad = Ordnerpfad & "\Prüfschein (" & Liste(i) & ").xlsx"
If Datei_vorhanden(Gesamtpfad) = True Then
If MsgBox("Es ist schon ein Prüfschein mit dem Namen (" & Liste(i) & ") mit der" & Chr(10) & Chr(10) & "Werknummer: " & Me.TextBox1 & Chr(10) & "Fabriknummer: " & Me.TextBox3 & Chr(10) & "Position: " & Me.TextBox4 & Chr(10) & Chr(10) & "vorhanden. Soll der vorhandene Prüfschein ersetzt werden?", vbInformation + vbYesNo, "Achtung Prüfschein schon vorhanden.") = vbYes Then
Application.DisplayAlerts = False
ThisWorkbook.Sheets(Liste(i)).Copy
ActiveWorkbook.SaveAs Filename:=Gesamtpfad, FileFormat:=51
ActiveWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
End If
Else
ThisWorkbook.Sheets(Liste(i)).Copy
ActiveWorkbook.SaveAs Filename:=Gesamtpfad, FileFormat:=51
ActiveWorkbook.Close savechanges:=False
End If
Next i
Application.ScreenUpdating = True

MsgBox "Prüfscheine wurden erfolgreich erstellt."

End Sub


3. Code

Public Sub Ordner_erstellen(Pfad As String)
Dim Pfade As Variant, i As Integer, j As Integer, k As Integer, ST As String, c As Variant

ReDim Pfade(i)

c = Split(Pfad, "\")

For j = LBound(c) To UBound(c)
If Trim(c(j)) <> "" Then
ReDim Preserve Pfade(i)
If j = 0 Then
ST = c(j)
Else
ST = ST & "\" & c(j)
End If
Pfade(i) = ST
i = i + 1
End If
Next j

For i = LBound(Pfade) To UBound(Pfade)
If Len(Dir(Pfade(i), vbDirectory)) = 0 Then
MkDir Pfade(i)
End If
Next i
End Sub

Hier wird ein Ordner erstellt

code 4


Public Sub Prüflisten_speichern(LB As Object, OP As String)
Dim i As Integer

With LB
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
ThisWorkbook.Sheets(.List(i)).Copy
ActiveWorkbook.SaveAs Filename:=OP & "\Prüfschein (" & .List(i) & ")"
ActiveWorkbook.Close savechanges:=False
Exit Sub
End If
Next i
End With

End Sub

Speichern der datein

gehörte alles zu einer Userform
------------------------------------------------------------------

eine weitere Userform. das ist das drucken von einzeln abgespeicherten Tabellenblättern die durch eine Listbox aufgerufen wird

Private Sub CommandButton1_Click()
Dim rngCell As Range, strFirstAddress As String, x As Long

With Worksheets("Kundenauflistung")
With .Range("A2:A" & .Rows.Count & "")
Me.ListBox1.Clear: ReDim Zeilen(x)
Set rngCell = .Find(Me.TextBox1.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not rngCell Is Nothing Then
strFirstAddress = rngCell.Address
Do
With Me.ListBox1
.AddItem
.List(.ListCount - 1, 0) = rngCell.Value
.List(.ListCount - 1, 1) = rngCell.Offset(0, 1).Value
.List(.ListCount - 1, 2) = rngCell.Offset(0, 2).Value
.List(.ListCount - 1, 3) = rngCell.Offset(0, 3).Value
ReDim Preserve Zeilen(x)
Zeilen(x) = rngCell.Row: x = x + 1
End With
Set rngCell = .FindNext(rngCell)
Loop While Not rngCell Is Nothing And rngCell.Address <> strFirstAddress
Else
MsgBox "Werknummer nicht gefunden", 53
End If
End With
End With
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub CommandButton3_Click() 'Prüfscheine Drucken
Dim WB As Workbook, i As Long

If Listbox_angewählt(Me.ListBox1) = False Or Listbox_angewählt(Me.ListBox2) = False Then Exit Sub
If Trim(Me.TextBox1) = "" Then Exit Sub


ChangePrinter Me.ComboBox1
Application.ScreenUpdating = False
With Me.ListBox2
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
Workbooks.Open (Dateipfade(i))
Set WB = ActiveWorkbook
WB.Sheets(1).PrintOut
WB.Close savechanges:=False
End If
Next i
End With
Application.ScreenUpdating = True
ChangePrinter Me.ComboBox1.List(Standard_drucker)
End Sub


Private Sub ListBox1_Click()
Me.ListBox2.Clear
Me.Label10.Caption = ""
If Trim(Me.TextBox1) = "" Or Me.ListBox1.ListIndex = -1 Then Exit Sub

With Worksheets("Kundenauflistung")
If Trim(.Cells(Zeilen(Me.ListBox1.ListIndex), 11)) = Trim(.Cells(Zeilen(Me.ListBox1.ListIndex), 12)) Then
Me.Label10.Caption = "GIS Anlagentypen" & Chr(10) & Trim(.Cells(Zeilen(Me.ListBox1.ListIndex), 11))
Else
Me.Label10.Caption = "GIS Anlagentypen" & Chr(10) & Trim(.Cells(Zeilen(Me.ListBox1.ListIndex), 11)) & Chr(10) & Trim(.Cells(Zeilen(Me.ListBox1.ListIndex), 12))
End If
End With

Prüfscheine_suchen
End Sub

Private Sub UserForm_Activate()
With Me.ListBox1
.ColumnCount = 4
.ColumnWidths = "2cm;4,9cm;3,5cm;2,5cm"
End With

Drucker_füllen
End Sub

Public Sub Prüfscheine_suchen()
Dim Ordnerpfad As String, Gesamtpfad As String, strDatei As String, lngZ As Long, x As Long

ReDim Dateipfade(x)

If Trim(Me.TextBox1) = "" Or Me.ListBox1.ListIndex = -1 Then Exit Sub

With Me.ListBox1
Ordnerpfad = Ordnergrundpfad & Trim(.List(.ListIndex, 0)) & "\" & Trim(.List(.ListIndex, 2)) & "\" & Trim(.List(.ListIndex, 3)) & "\"
End With

strDatei = Dir(Ordnerpfad & "*.xlsx")
Do Until strDatei = ""
Me.ListBox2.AddItem Left(strDatei, InStrRev(strDatei, ".") - 1)
ReDim Preserve Dateipfade(x)
Dateipfade(x) = Ordnerpfad & strDatei
x = x + 1
strDatei = Dir
Loop
End Sub

Public Sub Drucker_füllen()
Dim objWMIService As Object, colItems, objItem, Mem As String, zähler As Integer

Standard_drucker = 0: zähler = 0
'On Error Resume Next
Me.ComboBox1.Clear
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_Printer", , 48)
For Each objItem In colItems
Me.ComboBox1.AddItem objItem.Caption
Mem = objItem.Caption
If InStr(1, Application.ActivePrinter, Mem) Then Standard_drucker = zähler
zähler = zähler + 1
Next
Me.ComboBox1.ListIndex = Standard_drucker
End Sub



vll kann ja da jemand was mit anfangen zumindest um die funktionen zu erkläre ich würde auch die datei jemanden schicken wenn er sich dafür kurz zeit nehmen kann


gruß Chris

MWOnline
27.06.2014, 16:41
Hi,

dann machen wir mal den roten Block etwas klarer:

Me.ListBox2.Clear
ListBox2 auf der UserForm wird geleert

If Trim(Me.TextBox12) = "" Then Exit Sub
Wenn die TextBox12 leer ist wird vorzeitig beendet

For Each WS In ThisWorkbook.Worksheets
Schleife über alle Arbeitsblätter

If InStr(1, WS.Name, "Checkliste", 1) <> 0 Then
Wenn im Sheetnamen Checkliste vorkommt gehts weiter...

If InStr(1, Left(WS.Name, Len(WS.Name) - 7) & Right(WS.Name, 1), Me.TextBox12.Text, 1) <> 0 Then
wenn im Sheetname ohne die letzten 7 Zeichen zusammengesetzt mit dem letzten Zeichen des Sheetnamens der Inhaltes von Textbox12 vorkommt gehts weiter...

Me.ListBox2.AddItem WS.Name
ListBox2 bekommt diesen Sheetnamen hinzugefügt

End If
End If

If InStr(1, WS.Name, Me.TextBox12.Text, 1) <> 0 Then
Wenn im Sheetnamen der Inhalt der Textbox12 vorkommt...

Me.ListBox2.AddItem WS.Name
auch zur ListBox2 hinzufügen...

End If
Next WS
nächste Schleifenrunde...


Ich hoffe, es hilft Dir ein Stückweiter... ich hab jetzt Feierabend *freu*!

Allen im Forum ein wunderschönes Wochenende!!!

Beste Grüße und Viel Erfolg
Marc

chfu3
27.06.2014, 16:45
danke für den Anfang

zumindest mit dem ersten Code.

bleiben ja nur noch 6 oder 7:(

chfu3
27.06.2014, 17:46
Wenn mir jemand diesen Code erklären kann was da genau passiert und wie der Ablauf ist wäre super da seh ich garnicht durch



Private Sub CommandButton4_Click() 'Prüfscheine erstellen und speichern
Dim i As Integer, Ordnerpfad As String, Gesamtpfad As String, Weitermachen As Boolean, Liste As Variant, x As Integer, n As Integer


If Listbox_angewählt(Me.ListBox1) = False And Listbox_angewählt(Me.ListBox2) = False Then Exit Sub
If Trim(Me.TextBox1) = "" Or Trim(Me.TextBox3) = "" Or Trim(Me.TextBox4) = "" Then Exit Sub

ReDim Liste(x)

With Me.ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
Weitermachen = True
For n = LBound(Liste) To UBound(Liste)
If LCase(Liste(n)) = LCase(.List(i)) Then GoTo Weiter1
Next n
ReDim Preserve Liste(x)
Liste(x) = .List(i): x = x + 1
Weiter1:
End If
Next i
End With

With Me.ListBox2
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
Weitermachen = True
For n = LBound(Liste) To UBound(Liste)
If LCase(Liste(n)) = LCase(.List(i)) Then GoTo Weiter2
Next n
ReDim Preserve Liste(x)
Liste(x) = .List(i): x = x + 1
Weiter2:
End If
Next i
End With

If Weitermachen = False Then Exit Sub

Ordnerpfad = Ordnergrundpfad & Trim(Me.TextBox1) & "\" & Trim(Me.TextBox3) & "\" & Trim(Me.TextBox4)
Call Ordner_erstellen(Ordnerpfad)

Application.ScreenUpdating = False
For i = LBound(Liste) To UBound(Liste)
Gesamtpfad = Ordnerpfad & "\Prüfschein (" & Liste(i) & ").xlsx"
If Datei_vorhanden(Gesamtpfad) = True Then
If MsgBox("Es ist schon ein Prüfschein mit dem Namen (" & Liste(i) & ") mit der" & Chr(10) & Chr(10) & "Werknummer: " & Me.TextBox1 & Chr(10) & "Fabriknummer: " & Me.TextBox3 & Chr(10) & "Position: " & Me.TextBox4 & Chr(10) & Chr(10) & "vorhanden. Soll der vorhandene Prüfschein ersetzt werden?", vbInformation + vbYesNo, "Achtung Prüfschein schon vorhanden.") = vbYes Then
Application.DisplayAlerts = False
ThisWorkbook.Sheets(Liste(i)).Copy
ActiveWorkbook.SaveAs Filename:=Gesamtpfad, FileFormat:=51
ActiveWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
End If
Else
ThisWorkbook.Sheets(Liste(i)).Copy
ActiveWorkbook.SaveAs Filename:=Gesamtpfad, FileFormat:=51
ActiveWorkbook.Close savechanges:=False
End If
Next i
Application.ScreenUpdating = True

MsgBox "Prüfscheine wurden erfolgreich erstellt."

End Sub
----------------------------------------------------------------------------------------------
Public Sub Ordner_erstellen(Pfad As String)
Dim Pfade As Variant, i As Integer, j As Integer, k As Integer, ST As String, c As Variant

ReDim Pfade(i)

c = Split(Pfad, "\")

For j = LBound(c) To UBound(c)
If Trim(c(j)) <> "" Then
ReDim Preserve Pfade(i)
If j = 0 Then
ST = c(j)
Else
ST = ST & "\" & c(j)
End If
Pfade(i) = ST
i = i + 1
End If
Next j

For i = LBound(Pfade) To UBound(Pfade)
If Len(Dir(Pfade(i), vbDirectory)) = 0 Then
MkDir Pfade(i)
End If
Next i
End Sub
-----------------------------------------------------------------------------
Public Function Datei_vorhanden(Pfad As String) As Boolean
If Dir(Pfad) = "" Then
Datei_vorhanden = False
Else
Datei_vorhanden = True
End If
End Function


Public Function Listbox_angewählt(LB As Object) As Boolean
Dim i As Integer

With LB
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
Listbox_angewählt = True
Exit Function
End If
Next i
End With

End Function
--------------------------------------------------------------------------------
Public Sub Prüflisten_speichern(LB As Object, OP As String)
Dim i As Integer

With LB
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
ThisWorkbook.Sheets(.List(i)).Copy
ActiveWorkbook.SaveAs Filename:=OP & "\Prüfschein (" & .List(i) & ")"
ActiveWorkbook.Close savechanges:=False
Exit Sub
End If
Next i
End With

End Sub

RPP63neu
27.06.2014, 18:00
Hallo Chris!
Nix für ungut, aber wie stellst Du Dir das vor?
Du musst morgen (SIC!) einen nicht von Dir erstellten umfangreichen Code in einer Prüfung "verteidigen" und "bist noch nicht so firm in VBA und machst das gerade so das erste mal richtig" (Zitat)?

... und wenn sich hier dann jemand die Mühe macht, all das was man auch mit der kontextbezogenen Hilfe im VBE via F1 herausbekommen könnte, niederzuschreiben, was folgt dann?

Merkst Du Dir dann plötzlich, was Du in den vergangenen Monaten versäumt hast?

Nimmst Du Dein Notebook mit zur Prüfung und liest vor?

Meine persönliche Meinung: vergiss es, dies hat keinen Zweck!

Gruß, Ralf

chfu3
27.06.2014, 18:12
ja hab da def. einiges versäumt in den letzten beiden Monaten.
vorallem bei der bedeutung von den Funktionen

also def. hat sich in der zeit das interesse bei mir geweckt mehr damit zu machen um es besser zu verstehen. nur mit manchen Funktionen direkt kann ich noch nicht immer was anfangen. und ich versuch die vorallem zu verstehen. das ich das irgendwann mal aus dem FF kann.


gruß
chris