Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1356to1360
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Daten kopieren mit VBA
05.04.2014 11:48:52
giuppy
Hallo zusammen,
ich möchte Daten von eine Formular in eine anderen Excel Datei (Retourenschein) mit ein VBA Schreiben
hier mein Formular
Userbild
hier mein Retourenschein
Userbild
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

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
keine Lösung, nur Hinweis
05.04.2014 14:21:35
Oberschlumpf
Hi #Name?
zeig uns bitte Bsp-Dateien, die vom Aufbau genau so sind wie deine Originaldateien.
Füg da Bsp-Daten ein, wo erforderlich.
Auch VBA-Code und Userform bitte nicht vergessen.
Ciao
Thorsten

Daten kopieren mit schleife
06.04.2014 14:03:00
giuppy
Hallo Thorsten,
anbei die Vorlagen
ich möchte einfach die Daten kopieren NUR wenn in das Feld ID der Wert 1 geschrieben ist
Ich denke mit eine schleife sollte funktionieren aber ich Weiß nicht wie
man muss die (Lz) definieren
Oder hast du ein anderen Vorschlag?
wenn in (Tabelle Formular) das Feld ID der Wert 1 vorhanden ist dann sollen die Werte in die anderen Tabelle Retourenschein kopiert
z.B ID Feld A5 =1 (Zeile5) dann Lz=5
ID Feld A6 =1 (Zeile6) dann Lz=6
usw.
Es sollen bis maximal 10 Zeilen möglich sein ( bis art10)
PS was ist der Unterschied zwischen Makro Module und Userform ich habe immer Module benutzt
Viele Grüße
GIUPPY
Schleife ..... und dann
VBA
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
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
NEUE Lz
Art2 = Range("H" & Lz) ' Art2
ArtNa2 = Range("I" & Lz) ' Artikelname
Fb2 = Range("J" & Lz) ' Farbe2
Besch2 = Range("K" & Lz) 'Besch2
Gr2 = Range("L" & Lz) ' Große2
Men2 = Range("M" & Lz) ' Men2
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
NEUE Lz
Art3 = Range("H" & Lz) ' Art3
ArtNa3 = Range("I" & Lz) ' Artikelname
Fb3 = Range("J" & Lz) ' Farbe3
Besch3 = Range("K" & Lz) 'Besch3
Gr3 = Range("L" & Lz) ' Große3
Men3 = Range("M" & Lz) ' Men3
best = Range("Z" & Lz) ' bestätigung
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
bis maximal 10 Artikel
Userbild
Userbild

Anzeige
mein letzter Beitrag in diesem Thread
06.04.2014 14:30:44
Oberschlumpf
Hi
Was verstehst du nicht, wenn ich dich um BEISPIEL-DATEIEN bitte?
Anstelle dessen zeigst du wieder NUR Code + ne Grafik!!!
Sollen WIR deine datei nachbauen?
Nö, hab ich keine Lust zu! Außerden weiß ich gar nicht im Detail, wie deine Datei aussieht.
Aber deine Frage zum Unterschied zwischen, bzw die Bedeutung von Makro, Modul und Userform kann ich dir erklären.
Was ist ein Makro
http://de.wikipedia.org/wiki/Makro
noch mehr? dann hier
https://www.google.de/#newwindow=1&q=vba%20was%20ist%20ein%20makro
Was ist ein Modul?
http://www.online-excel.de/excel/singsel_vba.php?f=100
noch mehr? dann hier
https://www.google.de/#newwindow=1&q=vba+was+ist+ein+modul
Was ist ein Userform(ular)?
http://www.vba-wordwelt.de/grundsaetzliches/elemente-im-vba-editor/userform/
noch mehr? dann hier
https://www.google.de/#newwindow=1&q=vba%20was%20ist%20ein%20userform
Hilfts?
Ciao
Thorsten

Anzeige
AW: Daten kopieren mit schleife
06.04.2014 18:37:13
Crazy
Hallo
das wäre ein Weg
Option Explicit
Dim Suchergebnis As Range
Private Sub CommandButton1_Click()
Dim Ende As String
Dim iZaehlerZiel As Long
Dim firstAddress
Ende = Worksheets("2014").Cells(Rows.Count, 1).End(xlUp).Address 'letzte belegte Zeile
With Worksheets("2014")
With .Range("A4:" & Ende)
Set Suchergebnis = .Find(1, LookIn:=xlValues)
If Not Suchergebnis Is Nothing Then
firstAddress = Suchergebnis.Address
Worksheets("Vorl").Range("B19").Value = Suchergebnis.Offset(0, 6).Value
Worksheets("Vorl").Range("B20").Value = Suchergebnis.Offset(0, 5).Value
Do
Worksheets("Vorl").Cells(37, 1).End(xlUp).Offset(1, 0).Value = Suchergebnis. _
Offset(0, 12).Value
Worksheets("Vorl").Cells(37, 2).End(xlUp).Offset(1, 0).Value = Suchergebnis. _
Offset(0, 7).Value
Worksheets("Vorl").Cells(37, 3).End(xlUp).Offset(1, 0).Value = Suchergebnis. _
Offset(0, 8).Value
Worksheets("Vorl").Cells(37, 4).End(xlUp).Offset(1, 0).Value = Suchergebnis. _
Offset(0, 10).Value
Worksheets("Vorl").Cells(37, 5).End(xlUp).Offset(1, 0).Value = Suchergebnis. _
Offset(0, 9).Value
Worksheets("Vorl").Cells(37, 6).End(xlUp).Offset(1, 0).Value = Suchergebnis. _
Offset(0, 11).Value
If Suchergebnis.Offset(0, 14).Value = "sonstiges" Then
Worksheets("Vorl").Cells(37, 7).End(xlUp).Offset(1, 0).Value =  _
Suchergebnis.Offset(0, 14).Value
Else
Worksheets("Vorl").Cells(37, 7).End(xlUp).Offset(1, 0).Value = Left( _
Suchergebnis.Offset(0, 14), 1)
End If
If Suchergebnis.Offset(0, 15).Value = "sonstiges" Then
Worksheets("Vorl").Cells(37, 8).End(xlUp).Offset(1, 0).Value =  _
Suchergebnis.Offset(0, 15).Value
Else
Worksheets("Vorl").Cells(37, 8).End(xlUp).Offset(1, 0).Value = Left( _
Suchergebnis.Offset(0, 15), 1)
End If
iZaehlerZiel = iZaehlerZiel + 1
Set Suchergebnis = .FindNext(Suchergebnis)
Loop While Not Suchergebnis Is Nothing And Suchergebnis.Address  firstAddress
End If
End With
End With
End Sub
MfG Tom
Anzeige

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige