Herkunft des ListBox Items auslesen & Ändern

  • Excel

Es gibt 2 Antworten in diesem Thema. Der letzte Beitrag () ist von UltraTM.

    Herkunft des ListBox Items auslesen & Ändern

    Hallo,

    und zwar stehe ich vor folgender Aufgabe:

    Ich habe eine Form gebaut mit welcher ich nach einer Auftragsnummer Daten in eine Listbox auslese. Hiermit erstell ich eine WordDatei und fülle diese mit dem Inhalt. Auch erstelle ich einen Ordner auf dem Netzlaufwerk mit einem bestimmten Namen dieser Werte.
    Alles funktioniert wunderbar.

    Allerdings würde ich gerne Rückwärts Daten in die Herkunftsfelder schreiben. Ich weiß nur leider nicht wie ich dies bewerkstelligen kann/soll.
    Hintergrund ist folgender: Ich würde gerne in der gefunden Spalte A die erstellte Datei verlinken und in Spalte B den erstellen Ordner verlinken.

    Sprich wie kann ich z.b. .Cells(lngRow, TypProd) aus Private Sub cmdSuchen_Click() welches das Herkunftsfeld ist unten unter Private Sub CommandButton2_Click() dann befüllen.
    Über Hilfe wäre ich sehr dankbar.

    Anbei mein Code:
    Spoiler anzeigen

    Visual Basic-Quellcode

    1. Option Explicit
    3. Private Sub cmdSuchen_Click()
    4. Dim lngRow As Long, lngLast As Long
    6. 'Tauschbare Spalten/Zeilen für die Dateien
    7. Dim TypProd As String 'A
    8. Dim SNProd As String 'B
    9. Dim AufProd As String 'E
    10. Dim KunProd As String 'F
    11. Dim TierProd As String 'D
    12. Dim StandProd As String 'U
    13. Dim ErsteZeile As String 'Zahl 9
    15. 'Deklarien der Werte
    16. TypProd = Worksheets("Daten").Cells(16, 15).Value
    17. SNProd = Worksheets("Daten").Cells(17, 15).Value
    18. AufProd = Worksheets("Daten").Cells(18, 15).Value
    19. KunProd = Worksheets("Daten").Cells(19, 15).Value
    20. TierProd = Worksheets("Daten").Cells(20, 15).Value
    21. StandProd = Worksheets("Daten").Cells(21, 15).Value
    22. ErsteZeile = Worksheets("Daten").Cells(16, 18).Value
    24. If TextBox1.text <> "" Then
    25. With Sheets("Aktuell")
    26. lngLast = Application.Max(ErsteZeile, .Cells(.Rows.Count, 1).End(xlUp).Row)
    27. ListBox1.Clear
    28. For lngRow = ErsteZeile To lngLast
    29. 'If .Cells(lngRow, 5).Value = TextBox1 Then
    30. If InStr(1, .Cells(lngRow, AufProd).text, TextBox1.Value, 1) > 0 Then
    31. ListBox1.AddItem Cells(lngRow, 1).text
    32. ListBox1.Column(0, ListBox1.ListCount - 1) = .Cells(lngRow, TypProd).text 'typ
    33. ListBox1.Column(1, ListBox1.ListCount - 1) = .Cells(lngRow, SNProd).text 'Seriennummer
    34. ListBox1.Column(2, ListBox1.ListCount - 1) = .Cells(lngRow, AufProd).text 'Auftragsnummer
    35. ListBox1.Column(3, ListBox1.ListCount - 1) = .Cells(lngRow, KunProd).text 'Kunde
    36. ListBox1.Column(4, ListBox1.ListCount - 1) = .Cells(lngRow, TierProd).text 'TypeofCheck
    37. ListBox1.Column(5, ListBox1.ListCount - 1) = .Cells(lngRow, StandProd).text 'Standort
    38. End If
    39. Next
    40. End With
    41. Else
    42. MsgBox "Kein gültige Auftragsnummer!"
    43. End If
    45. End Sub
    47. Private Sub CommandButton2_Click()
    48. 'Variablen Listbox definieren
    49. With ListBox1
    50. 'Variablen definieren
    51. Dim lngIndex As Long, Ordnername As String, wrdApp As Object, wrdDoc As Object, strTemp As String, Number As String, Kunde As String, SN As String, Nummer As String
    53. '******************************************PCR erstellen Anfang********************************************************************************************************
    54. On Error GoTo FehlerVorlage
    55. strTemp = "Z:\Production\Quality Control\01 PCR\01 Vorlage\PCR_00000_Kunde.docx" 'Pfad zur Vorlage
    56. On Error Resume Next
    58. Set wrdApp = GetObject(, "Word.Application")
    60. If wrdApp Is Nothing Then
    61. Set wrdApp = CreateObject("Word.Application")
    62. End If
    64. With wrdApp
    65. Set wrdDoc = .documents.Add(strTemp) 'Neues Dokument auf Basis der Vorlage erstellen
    66. .Visible = True 'WORD-Fenster anzeigen - Auf True wenn Word offen bleiben soll zum Daten füllen
    67. End With
    68. Nummer = Nummerierung
    69. 'Eintragen der Werte in Worddatei
    70. wrdDoc.SelectContentControlsByTag("tagReportID").Item(1).Range.text = Nummer 'Cells(ActiveCell.Row, 1)
    71. wrdDoc.SelectContentControlsByTag("tagAuftragsnummer").Item(1).Range.text = .List(lngIndex, 2) 'tagAuftragsnummer
    72. wrdDoc.SelectContentControlsByTag("tagHalle").Item(1).Range.text = .List(lngIndex, 5) 'tagHalle
    73. wrdDoc.SelectContentControlsByTag("tagKunde").Item(1).Range.text = .List(lngIndex, 3) 'tagKunde
    74. wrdDoc.SelectContentControlsByTag("tagTypeofCheck").Item(1).Range.text = "Tier" & .List(lngIndex, 4) 'tagTypeofCheck
    75. If UCase(Left(.List(lngIndex, 0), 2)) = "HI" Then
    76. wrdDoc.SelectContentControlsByTag("tagRoboterSeriennummer").Item(1).Range.text = .List(lngIndex, 1) 'tagRoboterSeriennummer
    77. Else
    78. wrdDoc.SelectContentControlsByTag("tagSeriennummer").Item(1).Range.text = .List(lngIndex, 1) 'tagSeriennummer
    79. End If
    80. 'wrdDoc.SelectContentControlsByTag("tagMaschinenTyp").Item(1).Range.text = .List(lngIndex, 0) 'tagMaschinenTyp
    81. 'wrdDoc.SelectContentControlsByTag("tagSchließeinheit").Item(1).Range.text = .List(lngIndex, 0) 'tagSchließeinheit
    82. 'wrdDoc.SelectContentControlsByTag("tagEinspritzeinheit").Item(1).Range.text = .List(lngIndex, 0) 'tagEinspritzeinheit
    83. 'wrdDoc.SelectContentControlsByTag("tagRoboterTyp").Item(1).Range.text = 1 'tagRoboterTyp
    85. 'Hier speichern als neue Datei im bestimmten Pfad
    86. 'wrdDoc.PrintOut Background:=True
    87. Kunde = .List(lngIndex, 3)
    88. SN = .List(lngIndex, 1)
    89. wrdDoc.SaveAs Filename:="Z:\Production\Quality Control\01 PCR\02 Offen\PCR" & Nummer & "_" & Kunde & "_" & SN & ".docx"
    90. On Error GoTo FehlerVorlageSave
    91. 'On Error Resume Next
    92. Application.Wait Now + TimeSerial(0, 0, 3)
    94. 'Word im Hintergrund beenden und wieder alles freigeben
    95. 'wrdDoc.Saved = True
    97. 'Wenn Word offen bleibt nicht ausführen
    98. 'wrdDoc.Close
    99. 'wrdApp.Quit
    100. Set wrdDoc = Nothing
    101. Set wrdApp = Nothing
    102. '**************************************************PCR erstellen ende********************************************************************************************
    103. MsgBox "PCR erstellt!", vbInformation
    104. Worksheets("Daten").Cells(8, 14).Value = Nummerierung
    106. 'HIER LINK EINFÜGEN IN HERKUNFTS/GEFUNDENE FELD IN SPALTE A DER ERSTELLTEN DATEI EINTRAGEN
    108. '***************************************************************************************************************************************************************'
    109. '***********************************************Ordner erstellen Anfang*************************************************************************************
    110. 'Variablen definieren
    111. Dim filesystem As Object, Orndername As String, Maschine As String, MaschineSonder As String, Seriennummer As String, Auftrag As String, MaschineLeer As String
    112. 'MaschineLeer = LeerzeichenEntfernen(.List(lngIndex, 0))
    113. Maschine = Clean_Sonderzeichen(.List(lngIndex, 0))
    114. Seriennummer = .List(lngIndex, 1)
    115. Auftrag = .List(lngIndex, 2)
    117. Ordnername = Maschine & "_" & Seriennummer & "_" & Auftrag
    119. 'Ordner Vorlage kopieren und in anderem Ordner mit richtigem Namen einfügen
    120. Set filesystem = CreateObject("Scripting.FileSystemObject")
    121. filesystem.CopyFolder "Y:\Maschinendokumentation\4. Vorlagen\1. Maschinenordner\Maschine_Seriennummer_Auftrag", "Y:\Maschinendokumentation\99. in Bearbeitung\" & Ordnername
    122. Set filesystem = Nothing
    124. End With
    125. **************************************************************************************************************************************************************************
    126. 'Ordner erstellen Ende
    127. MsgBox "Ordner erstellt!", vbInformation
    130. 'HIER LINK EINFÜGEN IN HERKUNFTS/GEFUNDENE FELD IN SPALTE A DES ERSTELLTEN ORDNERS EINTRAGEN
    132. Exit Sub
    133. 'Fehler: MsgBox "Unerwarteter Fehler - Richtige Datei mit richtigem Blatt geöffnet ??"
    134. FehlerVorlage: MsgBox " Datei: " & strTemp & "Vorlage nicht vorhanden? und/oder keine Zugriff auf das Verzeichnis??" & Chr(10), vbOKOnly, " Fehler bitte prüfen "
    135. Exit Sub
    136. FehlerVorlageSave: MsgBox " Datei: " & strTemp & "Vorlage konnte nicht gespeichert werden? Kein Zugriff auf das Verzeichnis!" & Chr(10), vbOKOnly, " Fehler bitte prüfen "
    137. End Sub
    139. Private Sub CommandButton3_Click()
    140. TextBox1.Value = ""
    141. ListBox1.Clear
    142. End Sub
    144. 'Zentrieren auf beiden Bildschirmen des Fenstern
    145. Private Sub UserForm_Initialize()
    146. Dim sngTop As Single, sngLeft As Single
    147. Me.StartUpPosition = 0
    148. sngLeft = Application.Left + Application.Width / 2 - Me.Width / 2
    149. sngTop = Application.Top + Application.Height / 2 - Me.Height / 2
    151. Me.Left = sngLeft
    152. Me.Top = sngTop
    154. Label13 = Date
    155. Label28 = Time
    156. 'Spaltenbreite festlegen
    157. ListBox1.ColumnWidths = "90 Pt;70 Pt;70 Pt;70 Pt;20 Pt;70 Pt"
    158. End Sub
    160. 'Funktion Sonderzeichen in Namen entfernen und als _ ändern
    161. Function Clean_Sonderzeichen(ByVal strWert As String) As String
    162. '** Dimensionierung der Variablen
    163. Dim i As Integer
    164. Const strSonderzeichen As String = "-.,:;#+ß'*?=)(/&%$§!~\}][{"
    165. '** Durchlaufen des übergebenen Strings
    166. For i = 1 To Len(strSonderzeichen)
    167. strWert = Replace(strWert, Mid(strSonderzeichen, i, 1), "-") 'Statt Sonderzeichen einen Unterstrich einfügen
    168. Next i
    169. '** Bereinigter String der Funktion zurückgeben
    170. 'Clean_Sonderzeichen = LeerzeichenEntfernen(strWert)
    172. Clean_Sonderzeichen = Replace(strWert, " ", "_")
    174. End Function
    176. 'Funktion Leerzeichen in Namen entfernen
    177. Function LeerzeichenEntfernen(strText As String) As String
    178. Dim intZ As Integer
    180. For intZ = 1 To Len(strText)
    182. Select Case Mid(strText, intZ, 1)
    184. Case " "
    186. Case Else
    188. LeerzeichenEntfernen = LeerzeichenEntfernen & Mid(strText, intZ, 1)
    190. End Select
    191. Next intZ
    192. End Function
    194. 'Funktion Fortlaufende Nummer generieren für PCRs
    195. Function Nummerierung() As String
    196. Dim lngRow As Long, intJahr As Integer, intMaxNr As Integer
    197. intJahr = (Year(Date) - 2000) * 1000 '22000 für 2022
    198. With Sheets("Daten")
    199. lngRow = Worksheets("Daten").Cells(8, 14).Value
    200. intMaxNr = Worksheets("Daten").Cells(8, 14).Value
    201. End With
    202. If lngRow > 1 Then
    203. If intMaxNr < intJahr Then 'letzte Nr ist aus vergangenem Jahr, z.B. 21456
    204. Nummerierung = intJahr + 1 '22001
    205. Else
    206. Nummerierung = intMaxNr + 1 'höchste Nr + 1
    207. End If
    208. Else
    209. Nummerierung = intJahr + 1 '22001
    210. End If
    211. 'Debug.Print Nummerierung
    212. 'Worksheets("Daten").Cells(8, 14).Value = Nummerierung
    213. End Function



    aufgrund des Codeumfangs Spoiler hinzugefügt ~VaporiZed

    Dieser Beitrag wurde bereits 3 mal editiert, zuletzt von „UltraTM“ ()

    Vollzitat des direkten Vorposts an dieser Stelle entfernt ~VaporiZed
    Hallo HenryV,

    stimmt darüber hatte ich gar nicht nachgedacht. Habe nun die Zeilennummer abgegriffen und damit gearbeitet um die jeweiligen Spalten anzusprechen.

    Vielen Dank für den Wertvollen Tip. Manchmal denkt man einfach sehr kompliziert.

    Grüße René

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „VaporiZed“ ()

Facebook
Telefonspende