Hi Stefan
Glaube ebenfalls dass es daran liegt, insbesondere im Teil Do While...Loop.
Zwar ungetestet, aber mal die Variablen ein bischen gesäubert. z.B.
Dim X, Y As Long
X = Variant
Y = Long
Anyway...
Option Explicit
Sub ModErg()
Dim MatNr(4) As Long
Dim Z As String, MatNrTxt(4) As String
Dim I As Long, J As Long, LModD As Long, LNetz As Long
Dim PId(2) As String, TPTyp As String, PTyp As String, TDN As String, STATUS As String, WUNSCH As String, IST As String
Dim EDSNR As Long
Dim PIDNetz As String, SL As String
Dim WBNetz As Workbook, WBModD As Workbook, WBOrgD As Workbook
Dim WSNetz As Worksheet, WSModD As Worksheet, WSOrgD As Worksheet
MatNr(1) = 100 'Produkt1
MatNr(2) = 101 'Produkt2
MatNr(3) = 102 'Produkt3
MatNr(4) = 103 'Produkt4
MatNrTxt(1) = "Text1"
MatNrTxt(2) = "Text2"
MatNrTxt(3) = "Text3"
MatNrTxt(4) = "Text4"
Set WBNetz = Workbooks("NetzwertExcel.xls")
Set WBModD = Workbooks("ModListErg.xls")
Set WBOrgD = Workbooks("ModListErg.xls")
Set WSNetz = WBModD.Worksheets(1)
Set WSModD = WBModD.Worksheets(1)
Set WSOrgD = WBOrgD.Worksheets(1)
LNetz = WSNetz.UsedRange.Rows.Count
EDSNR = 49999999
LModD = WSModD.UsedRange.Rows.Count
For I = 2 To LModD
EDSNR = EDSNR + 1
WSOrgD.Rows("2:2").Copy
WSModD.Activate
Cells(I, 1).Select
Selection.EntireRow.Insert
LModD = WSModD.UsedRange.Rows.Count
I = I + 1
PTyp = WSModD.Cells(I, 31).Value
PId(1) = WSModD.Cells(I, 12).Value
For J = 2 To LNetz
PIDNetz = WSNetz.Cells(J, 3).Value
If PIDNetz = PId(1) Then
SL = WSNetz.Cells(J, 8).Value
J = LNetz
End If
Next J
TDN = WSModD.Cells(I, 2).Value
STATUS = WSModD.Cells(I, 13).Value
WUNSCH = WSModD.Cells(I, 23).Value
IST = WSModD.Cells(I, 25).Value
WSModD.Cells(I - 1, 2).Value = TDN
WSModD.Cells(I - 1, 3).Value = EDSNR
WSModD.Cells(I - 1, 11).Value = PId(1) 'OrdnungsNr.
WSModD.Cells(I - 1, 13).Value = STATUS
WSModD.Cells(I - 1, 23).Value = WUNSCH
WSModD.Cells(I - 1, 25).Value = IST
WSModD.Cells(I - 1, 54).Value = SL
SL = ""
WSModD.Cells(I - 1, 56).Value = Right(TDN, 4)
TPTyp = Left(PTyp, 2)
Select Case TPTyp
Case "LM"
WSModD.Cells(I - 1, 43).Value = MatNr(1)
WSModD.Cells(I - 1, 44).Value = MatNrTxt(1)
WSModD.Cells(I - 1, 52).Value = PTyp & " Port"
If Left(PTyp, 3) = "LMS" Then
WSModD.Cells(I - 1, 50).Value = "LMS"
Else
WSModD.Cells(I - 1, 50).Value = "LM"
End If
Case "LR"
WSModD.Cells(I - 1, 43).Value = MatNr(2)
WSModD.Cells(I - 1, 44).Value = MatNrTxt(2)
WSModD.Cells(I - 1, 50).Value = "LR"
WSModD.Cells(I - 1, 52).Value = PTyp & " Port"
Case "LP"
WSModD.Cells(I - 1, 43).Value = MatNr(3)
WSModD.Cells(I - 1, 44).Value = MatNrTxt(3)
WSModD.Cells(I - 1, 50).Value = "LP"
WSModD.Cells(I - 1, 52).Value = PTyp & " Port"
Case Else
WSModD.Cells(I - 1, 43).Value = MatNr(4) 'Auslandsports
WSModD.Cells(I - 1, 44).Value = MatNrTxt(4)
WSModD.Cells(I - 1, 50).Value = "AP"
WSModD.Cells(I - 1, 52).Value = PTyp
End Select
PId(1) = WSModD.Cells(I, 12).Value
PId(2) = WSModD.Cells(I + 1, 12).Value
Do While PId(2) = PId(1)
I = I + 1
PId(2) = WSModD.Cells(I + 1, 12).Value
Loop
Next I
End Sub
Gruss
Chris