ich möchte Daten von eine Formular in eine anderen Excel Datei (Retourenschein) mit ein VBA Schreiben
hier mein Formular
hier mein Retourenschein
ich habe schon ein VBA geschrieben und funktioniert wenn allen Daten (maximal3 )in eine Zeile geschrieben sind ich möchte aber die Daten bis maximal 10 nicht in einer Zeile schreiben aber untereinander pro Kunde und Rechnr kann dasselbe LNR vorhanden sein und NUR wenn ich die zahl 1 in der ID spalte schreibe werden die Daten in die anderen Tabelle geschrieben wie kann ich das Problem lösen
hier mein VBA
Sub Retouren()
LZlnr = Cells.Find("*", [C1], , , xlByRows, xlPrevious).Row
lzlnrx = Range("B" & LZlnr)
Range("AG1").Select
ActiveCell.FormulaR1C1 = lzlnrx
Range("AH1").Select
ActiveCell.FormulaR1C1 = _
"=IF((COUNTIF(R[4]C[-32]:R[2999]C[-32],RC[-1])>1)=TRUE,1,0)"
Range("B" & LZlnr).Select
If Range("AH1") = 1 Then 'LNR prüfen
MsgBox "LNR schon vorhanden, bitte Folgenummer verwenden s.Zeile 2"
Else
Application.ScreenUpdating = False
Dim Name As String
Name = (InputBox("Bitte geben Sie Ihren Namen ein:", "Namen eingeben"))
'MsgBox ("Ihr Name lautet: " & Name)
If Name "" Then
Workbooks.Open Filename:= _
"G:\RETOUREN\Retourenschein nichtlöschen.xlsx"
Windows("Retourenschein nichtlöschen.xlsx").Activate
Range("D13,B15,A28:H47,F50,B54:B56").Select
Selection.ClearContents
Range("A28").Select
Windows("RetourenscheinSERVER 2014.xlsm").Activate
Sheets("2014").Select
Lz = Range("A65536").End(xlUp).Row
If WorksheetFunction.Sum(Range("A4:A3000")) = 0 Then ' ID
MsgBox "Falsche Eingabe in der Spalte ID muss die Nr. 1 vorkommen."
Windows("Retourenschein nichtlöschen.xlsx").Close saveChanges = True
Else
If WorksheetFunction.Sum(Range("A4:A3000")) > 1 Then
MsgBox "Falsche Eingabe in der Spalte ID darf die 1 nur einmal vorkommen. Jede Zeile muss _
_
einzeln gedruckt werden. Die jeweils zu druckende Zeile muss dabei mit einer 1 in der Spalte ID _
gekennzeichnet sein. "
Windows("Retourenschein nichtlöschen.xlsx").Close saveChanges = True
Else
Lz1 = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
LNRPrint = Range("B" & Lz)
DruckDat = "Letzte gedruckte LNR " & LNRPrint & " Zeilenr. " & Lz & " gedruckt am " & Date & _
_
" um " & Time & " von " & Name
Range("B2").Select '
'ActiveCell.FormulaR1C1 = "=""Letzte LNR ""&MAX(R[2]C:R[2998]C)"
ActiveCell.FormulaR1C1 = "=""Letzte LNR ""&TEXT(MAX(R[2]C:R[2998]C),""0000"")"
'Cells(lz, 1) = Time
Range("B3").Select
ActiveCell.FormulaR1C1 = DruckDat
Range("AG" & Lz).Select
ActiveCell.FormulaR1C1 = DruckDat
LNR1 = Range("B" & Lz) ' LNR
LNR = Format((LNR1), "0000")
Dat1 = Range("C" & Lz) 'Datum
RgNr = Range("D" & Lz) ' Rech.Nr
vom = Range("E" & Lz) ' vom
KdNr = Range("F" & Lz) 'KundeNr
KdNa = Range("G" & Lz) ' Kunden Name
Art1 = Range("H" & Lz) ' Art1
ArtNa = Range("I" & Lz) ' Artikelname
Fb1 = Range("J" & Lz) ' Farbe1
Besch1 = Range("K" & Lz) 'Besch1
Gr1 = Range("L" & Lz) ' Große1
Men1 = Range("M" & Lz) ' Men1
Art2 = Range("N" & Lz) ' Art2
ArtNa2 = Range("O" & Lz) ' Artikelname
Fb2 = Range("P" & Lz) ' Farbe2
Besch2 = Range("Q" & Lz) 'Besch2
Gr2 = Range("R" & Lz) ' Große2
Men2 = Range("S" & Lz) ' Men2
Art3 = Range("T" & Lz) ' Art3
ArtNa3 = Range("U" & Lz) ' Artikelname
Fb3 = Range("V" & Lz) ' Farbe3
Besch3 = Range("W" & Lz) 'Besch3
Gr3 = Range("X" & Lz) ' Große3
Men3 = Range("Y" & Lz) ' Men3
best = Range("Z" & Lz) ' bestätigung
'RekG = Range("X" & Lz) ' Reklamationsgrund
Range("AL" & Lz).Select
ActiveCell.FormulaR1C1 = "=MID(RC[-11],1,1)"
RekG1 = Range("AL" & Lz) ' nur Nummer
'RetG = Range("Y" & Lz) ' Retourengrund
Range("AM" & Lz).Select
ActiveCell.FormulaR1C1 = "=MID(RC[-11],1,1)"
RetG1 = Range("AM" & Lz) ' nur Nummer
Windows("Retourenschein nichtlöschen.xlsx").Activate
Sheets("Vorl").Select
Range("D13").Select 'LNR
ActiveCell.FormulaR1C1 = LNR
Range("B15").Select 'Datum
ActiveCell.FormulaR1C1 = Dat1
Range("B19").Select 'Kunde/Name
ActiveCell.FormulaR1C1 = KdNa
Range("B20").Select 'Kunden Nr.
ActiveCell.FormulaR1C1 = KdNr
Range("A28").Select 'Stück
ActiveCell.FormulaR1C1 = Men1
Range("B28").Select 'EDV-Code
ActiveCell.FormulaR1C1 = Art1
Range("C28").Select 'Artikelname
ActiveCell.FormulaR1C1 = ArtNa
Range("D28").Select 'Beschreibung
ActiveCell.FormulaR1C1 = Besch1
Range("E28").Select 'FB1
ActiveCell.FormulaR1C1 = Fb1
Range("F28").Select 'Größe
ActiveCell.FormulaR1C1 = Gr1
Range("G28").Select 'RekG
ActiveCell.FormulaR1C1 = RekG1
Range("H28").Select 'RetG
ActiveCell.FormulaR1C1 = RetG1
Range("A29").Select 'Stück
ActiveCell.FormulaR1C1 = Men2
Range("B29").Select 'EDV-Code
ActiveCell.FormulaR1C1 = Art2
Range("C29").Select 'Artikelname
ActiveCell.FormulaR1C1 = ArtNa1
Range("D29").Select 'Beschreibung
ActiveCell.FormulaR1C1 = Besch2
Range("E29").Select 'FB2
ActiveCell.FormulaR1C1 = Fb2
Range("F29").Select 'Größe
ActiveCell.FormulaR1C1 = Gr2
Range("G29").Select 'RekG
ActiveCell.FormulaR1C1 = RekG1
Range("H29").Select 'RetG
ActiveCell.FormulaR1C1 = RetG1
Range("A30").Select 'Stück
ActiveCell.FormulaR1C1 = Men3
Range("B30").Select 'EDV-Code
ActiveCell.FormulaR1C1 = Art3
Range("C29").Select 'Artikelname
ActiveCell.FormulaR1C1 = ArtNa2
Range("D30").Select 'Beschreibung
ActiveCell.FormulaR1C1 = Besch2
Range("E30").Select 'FB3
ActiveCell.FormulaR1C1 = Fb3
Range("F30").Select 'Größe
ActiveCell.FormulaR1C1 = Gr3
Range("G30").Select 'RekG
ActiveCell.FormulaR1C1 = RekG1
Range("H30").Select 'RetG
ActiveCell.FormulaR1C1 = RetG1
Range("B54").Select 'Rechnungs-Nr.
ActiveCell.FormulaR1C1 = RgNr
Range("B56").Select 'vom
ActiveCell.FormulaR1C1 = vom
Range("F51").Select 'genemigt
ActiveCell.FormulaR1C1 = best
ActiveWindow.SelectedSheets.PrintOut Copies:=1
ActiveWorkbook.Close saveChanges = True '/ False
End If 'ID >1
End If ' ID = 0
Else ' Name
ActiveWorkbook.Close
End If ' Name
End If ' LNR
Windows("RetourenscheinSERVER 2014.xlsm").Activate
Sheets("2014").Select
Range("A5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("L5").Select
Range("C5").Select
Selection.End(xlDown).Select
End Sub