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
Dim periodicArr(1 To 30)
Dim maxStorageArr(1 To 30)
Dim Excel As Object
For n = 1 To 30
periodicArr(n) = 999999
maxStorageArr(n) = 999999
Next n
Set Excel = CreateObject("Excel.Application")
Excel.Workbooks.Open (ActiveDocument.Path & "\xyz.xls")
Excel.Application.Visible = False
MaxZeilenExcel = Excel.Sheets("Tabelle1").Range("C1")
arrCounterMaxStorage = 1
arrCounterPeriodic = 1
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 periodicArr
bubbleSort maxStorageArr
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
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"
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
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
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
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"
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
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
Excel.Quit
Set Excel = Nothing
End Sub
Function nextLine()
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
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<span style="display: none"> </span>
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