|
Hallo VBA-Forum,
ich bin langsam am verzweifeln, weil VBA nicht wie ein "normales" Programm reagiert.
Die Ausgangssituation:
Ich habe eine Excel-Datei die sich öfters ändert und in der z.Zt. ca. 1000 Datenysätze von Lagerartikeln sind, die in regelmäßigem Abstand überprüft werden müssen und die nach einer maximalen Lagerzeit ggf. eine besonderen Behandlung unterzogen werden müssen.
Die Tabelle ist prinzipiell wie folgt aufgebaut:
Artikel | Zeitraum der Regelmäßigen Prüfung | maximale Lagerdauer | Aktion bei Erreichen der regelmäßigen Prüfung| Notwendiges Werkzeug zur regelmäßigen Prüfung | Aktion bei Erreichen der maximalen Lagerdauer
Diese Informationen sollen in ein Word-Dokument überführt werden. Dazu habe ich in Word ein VBA-Makro geschrieben. Folgendes soll passieren am Beispiel regelmäßige Überprüfung:
-
Im Word Dokument die richtige Überschrift finden und dahinter alle bisherigen Einträge bis zur nächsten Überschrift löschen.
-
An die freie Stelle sollen nach und nach
-
Erster Regelmäßiger Prüfzeitpunkt aus Excel eintragen (Format 2. Überchriftenebene); Zeilenwechesel in die nächste Zeile
-
Artikelnummer aus Excel eintragen (Format 3. Überschriftenebene); Zeilenwechesel in die nächste Zeile
-
1. Fixer Text eintragen (Format Unterschrichen); Zeilenwechesel in die nächste Zeile
-
Text aus Excel eintragen (Format Standard); Zeilenwechesel in die nächste Zeile
-
Zeilenwechesel in die nächste Zeile
-
2. Fixer Text eintragen (Format Unterstrichen); Zeilenwechesel in die nächste Zeile
-
Text aus Excel eintragen (Format Standard); Zeilenwechesel in die nächste Zeile
-
Zeilenwechesel in die nächste Zeile
-
nächste Artieklnummer
-
nächster Regelmäßiger Prüfzeitpunkt
-
usw.
Abhängig davon, ob ich das Makro automatisch ablaufen lasse oder ob ich es über den Debugger teilweise oder ganz über Einzelschritt durchlaufen lasse, kommen jedesmal unterschiedliche Ergebnisse raus. Folgende Probleme treten auf:
-
bei einzelnen (immer gleichen) Einträgen wird die Formatierung von 1. Fixen Text und nachfolgendem Text vertauscht
-
manchmal überspringt das Programm anscheinend einfach die letzte Überschrift und schreibt in der dritten Überschrift weiter.
Ziel sollte sein (kursiv soll unterstrichen darstellen):
6. Periodic Action
6.1 3 Month
6.1.1 99887766
Action Required
Schau das Teil mal an
Tool
Hände
6.1.2 009988
usw.
7 Maximum Storage
Es ist nicht nachvollziehbar, warum machnmal die Formatierung vertauscht wird, aber wenn ich die Zeile über Einzelschritt ausführe, die Formatierung stimmt..... Vielleicht kann mir hier jemand weiterhelfen.
Hier kommt der gesamte Programm-Code:
Dim MaxZeilenExcel, flag As Integer
Dim partnumber, excelActionText, excelToolsText As String
Const actionText As String = "Action Required"
Const toolsText As String = "Tools necessary"
Const maxActionText As String = "Action to be done at the limit of storage"
Sub Copy_From_Excel()
'
'
Dim arrCounterPeriodic, maxPeriodicArr As Integer
Dim i, j As Long ' Zähler
Dim periodicArr(1 To 30)
Dim maxStorageArr(1 To 30)
' Excel Objekt variable anlegen
Dim Excel As Object
For n = 1 To 30
periodicArr(n) = 999999
maxStorageArr(n) = 999999
Next n
' produce Excel Objec
Set Excel = CreateObject("Excel.Application")
' open Excel File
Excel.Workbooks.Open (ActiveDocument.Path & "\xyz.xls")
' Excel invisible
Excel.Application.Visible = False
' get maximum number of rows from Excel File
MaxZeilenExcel = Excel.Sheets("Tabelle1").Range("C1")
' reset counter
arrCounterMaxStorage = 1
arrCounterPeriodic = 1
' Fill arrays with the available "periodic actions" and "max storage" times
' no duplicates possible
For n = 3 To MaxZeilenExcel
If Excel.Cells(n, 6) <> "" Then
fillArray Excel, arrCounterPeriodic, periodicArr, n, 6
End If
If Excel.Cells(n, 5) <> "" Then
fillArray Excel, arrCounterMaxStorage, maxStorageArr, n, 5
End If
Next n
maxPeriodicArr = arrCounterPeriodic - 1
maxMaxStorage = arrCounterMaxStorage - 1
' BubbleSort arrays
bubbleSort periodicArr
bubbleSort maxStorageArr
' Find Chapter 6 Periodic Actions
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles(wdStyleHeading1)
Selection.Find.Replacement.Highlight = True
With Selection.Find
.Text = "Periodic"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
paLineCounter = 0
' Count lines until next chapter
Do
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
Selection.HomeKey Unit:=wdLine, Extend:=wdMove
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
paLineCounter = paLineCounter + 1
Loop Until Selection = "Maximum storage time"
' Find Chapter 6 Periodic Actions
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles(wdStyleHeading1)
Selection.Find.Replacement.Highlight = True
With Selection.Find
.Text = "Periodic"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
'Delete everything between the chapters
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
If paLineCounter > 2 Then
Selection.MoveDown Unit:=wdLine, Count:=paLineCounter - 2, Extend:=wdExtend
Selection.Delete
Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
Selection.Delete
End If
copyData maxPeriodicArr, periodicArr, "mp", Excel
' Find Chapter 7 Periodic Actions
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles(wdStyleHeading1)
Selection.Find.Replacement.Highlight = True
With Selection.Find
.Text = "Maximum"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
msLineCounter = 0
' Count lines until next chapter
Do
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
Selection.HomeKey Unit:=wdLine, Extend:=wdMove
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
msLineCounter = msLineCounter + 1
Loop Until Selection = "Cross matrix of PN with storage requirements"
' Find Chapter 7 Periodic Actions
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles(wdStyleHeading1)
Selection.Find.Replacement.Highlight = True
With Selection.Find
.Text = "Maximum"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
' Delete everything between the chapters
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
If msLineCounter > 2 Then
Selection.MoveDown Unit:=wdLine, Count:=msLineCounter - 2, Extend:=wdExtend
Selection.Delete
Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
Selection.Delete
End If
copyData maxMaxStorage, maxStorageArr, "ms", Excel
'ActiveDocument.TablesOfContents(1).Update
' Close Excel
Excel.Quit
' dextroy Excel object
Set Excel = Nothing
End Sub
Function nextLine()
'Insert LF and move cursor to next line wihtout selecting
Selection.InsertAfter Chr(13)
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
End Function
Function bubbleSort(Arr)
Dim vDummy As Variant
For j = UBound(Arr) - 1 To LBound(Arr) Step -1
For i = LBound(Arr) To j
If Arr(i) > Arr(i + 1) Then
vDummy = Arr(i)
Arr(i) = Arr(i + 1)
Arr(i + 1) = vDummy
End If
Next i
Next j
End Function
Function fillArray(funcExcel, counterArray, Arr, y, z)
flag = 0
For m = 1 To counterArray
If Arr(m) = funcExcel.Cells(y, z) Then
flag = 1
Exit For
End If
Next m
If flag = 0 Then
Arr(counterArray) = funcExcel.Cells(y, z)
counterArray = counterArray + 1
End If
End Function
Function copyData(arrMax, Arr, dec, funcExcel)
For k = 1 To arrMax
' checkflag to ensure that there is at least one P/N otherwise "None" will be inserted
flag = 0
Selection.InsertAfter CStr(Arr(k))
Selection.InsertAfter " Month"
Selection.Style = ActiveDocument.Styles("Überschrift 2")
nextLine
Selection.Style = ActiveDocument.Styles("Standard")
For h = 3 To MaxZeilenExcel
If funcExcel.Worksheets("Tabelle1").Cells(h, 6) = Arr(k) Then
flag = 1
partnumber = funcExcel.Worksheets("Tabelle1").Cells(h, 1)
Selection.InsertAfter partnumber
Selection.Style = ActiveDocument.Styles("Überschrift 3")
nextLine
Selection.Style = ActiveDocument.Styles("Standard")
If funcExcel.Worksheets("Tabelle1").Cells(h, 8) <> "" Then
excelActionText = funcExcel.Worksheets("Tabelle1").Cells(h, 8)
Else
excelActionText = "None"
End If
If dec = "mp" Then
If funcExcel.Worksheets("Tabelle1").Cells(h, 12) <> "" Then
excelToolsText = funcExcel.Worksheets("Tabelle1").Cells(h, 12)
Else
excelToolsText = "None"
End If
Selection.InsertAfter actionText
Selection.Font.Underline = wdUnderlineSingle
nextLine
Selection.Style = ActiveDocument.Styles("Standard")
Selection.InsertAfter excelActionText
nextLine
nextLine
Selection.InsertAfter toolsText
Selection.Font.Underline = wdUnderlineSingle
nextLine
Selection.Style = ActiveDocument.Styles("Standard")
Selection.InsertAfter excelToolsText
nextLine
nextLine
ElseIf dec = "ms" Then
Selection.InsertAfter maxActionText
Selection.Font.Underline = wdUnderlineSingle
nextLine
Selection.Style = ActiveDocument.Styles("Standard")
Selection.InsertAfter excelActionText
nextLine
nextLine
End If
End If
Next h
If flag = 0 Then
Selection.InsertAfter "None"
nextLine
nextLine
End If
Next k
End Function
|