Office: Bestimte Daten von Exportieren

Hallo Zusammen
Ich hoffe jemand von euch kan mir Helfen.

Ich versuche Aus einer Excel Mappe( Datei) Bestimte Werte in eine Neue Datei zu exportieren.
Je nach eingabe müsste es in eine Andere Mappe exportiert werden¨z.B
Zelle A12 = Bern Export aller Daten in Excel Datei Bern

Oder

Zelle A12 = Olten Eport Aller Daten in Exel Datei Olten.

Diese Eingaben werden über eine Eingabe Maske gemacht und werden immer widerer überschrieben.


Kann mir da jemand Helfen

 

Moinsens!

Folgender Code hinter einem Button dürfte eigentlich das machen, was Du brauchst, nachdem Du es ein wenig angepaßt hast:

Code:

Option Explicit

Private Sub btn_Export_Click()

    Const d = "[COLOR=#ff0000]C:[/COLOR]"
    Const p = "[COLOR=#ff0000]\temp\[/COLOR]"
    Const x = "[COLOR=#ff0000].xls[/COLOR]"

    Dim w1 As Workbook
    Dim s1 As Worksheet
    Dim r1 As Range
    Dim w2 As Workbook
    Dim s2 As Worksheet
    Dim r2 As Range

    Dim f As String
    Dim dpfx As String

' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    f = Trim$(Range("a12").Value)
    dpfx = d & p & f & x

    On Error GoTo NoFile
    Workbooks.Open dpfx
    On Error GoTo 0

    Set w1 = ThisWorkbook
    Set s1 = w1.Worksheets("[COLOR=#ff0000]data[/COLOR]")
    Set r1 = s1.Range("[COLOR=#ff0000]c3:e5[/COLOR]")

    Set w2 = ActiveWorkbook
    On Error GoTo NoSheet
    Set s2 = w2.Worksheets("[COLOR=#ff0000]data[/COLOR]")
    On Error GoTo 0
    Set r2 = s2.Range("[COLOR=#ff0000]g7[/COLOR]")

    'a) kopiert mit Formaten, Formeln usw.
    'On Error GoTo NoCopy
    'r1.Copy Destination:=r2
    'On Error GoTo 0

    'b) kopiert ohne Formate usw., nur Werte
    On Error GoTo NoCopy
    r1.Copy
    r2.PasteSpecial Paste:=xlPasteValues
    On Error GoTo 0
    Application.CutCopyMode = False

    w2.Close savechanges:=True

' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

ExitSub:
    Exit Sub

NoFile:
    On Error GoTo 0
    MsgBox "'" & dpfx & "' not found!"
    Resume ExitSub

NoSheet:
    On Error GoTo 0
    MsgBox "Worksheet 'data' not found in '" & f & "'!"
    Resume ExitSub

NoCopy:
    On Error GoTo 0
    MsgBox "copy failed!"
    Resume ExitSub

End Sub

Ohne weitere Anpassungen müßte der Code eigentlich jetzt folgendes tun:
- Wert aus Zelle A12 auslesen
- Mit "C:\temp\" vorweg und ".xls" dahinter erweitern
- Die Mappe öffnen
- aus dem Blatt "data" in der eigenen Mappe den Bereich C3:E5 kopieren
- in das Blatt "data" der neu geöffneten Mappe ab Zelle G7 einfügen
- die geänderte Mappe schließen (mit speichern)

Du müßtest jetzt noch das Laufwerk "Const d ...", den Pfad "Const p ..." und die Excel Datei-Erweiterung "Const x ..." anpassen.

Außerdem mußt Du den Bereich "von" und "bis" anpassen. Das geschieht in den Zeilen
"Set s1 ..." --> Name des Quell-Worksheets
"Set r1 ..." --> Bereich, der kopiert werden soll
"Set s2 ..." --> Name des Ziel-Worksheets
"Set r2 ..." --> Bereich (linke ober Zelle), wo eingefügt werden soll

Gruß, Michael

 

Hallo Mirki
Sorry habe erst jetzt gesehn das du mir Geantwortet hast schon mal ganz herzlichen Dank!

Ich versuche es sofort...
Nochmals Ganz herzlichen Dank
Gruss Marcel

 

Hallo Michael
Funktioniert Super besten dank...
Eine frage oder Problem habe ich noch , bin halt wirklich ein riesen Angfänger :-(

Bei diesem Teil
Set w1 = ThisWorkbook
Set s1 = w1.Worksheets("data")
Set r1 = s1.Range("c3:e5") da möchte ich einzelen Zellen eingeben (d3,d7,a12,c12,d12 und e12
Wie genau muss ich das machen?

Etwas anderes habe ich auch noch was nicht ganz so funktioniert.
in der neuen Tabelle wo es exportiert wirt sollte es immer in die nächste lehre zeille speichern... das schaffi ich bis jetzt auch noch nicht :-(
Sorry für die vielen Fragen

Liebe Grüsse

Marcel

 

Moinsens!

Du kannst jeden beliebigen Bereich in den "" angeben, statt "c3:e5" kannst Du dort auch gerne "d3" reinschreiben.

Aber... Diese Zeile steht ja nicht alleine. Zusammen mit r2 und der copy-Zeile wird das ja erst vollständig. Willst Du also mehrere Bereiche (und ein Bereich kann auch eine einzelne Zelle sein) kopieren, mußt du den ganzen Block entsprechend mehrmals haben.

Gekürzt bräuchtest du also sowas wie:

Code:

    Set r1 = s1.Range("[COLOR=#ff0000]d3[/COLOR]") : Set r2 = s2.Range("[COLOR=#ff0000]g7"[/COLOR]) : r1.Copy : r2.PasteSpecial Paste:=xlPasteValues
    Set r1 = s1.Range("[COLOR=#FF0000]d7[/COLOR]") : Set r2 = s2.Range("[COLOR=#FF0000]g8"[/COLOR]) : r1.Copy : r2.PasteSpecial Paste:=xlPasteValues
    Set r1 = s1.Range("[COLOR=#FF0000]a12[/COLOR]") : Set r2 = s2.Range("[COLOR=#FF0000]g9"[/COLOR]) : r1.Copy : r2.PasteSpecial Paste:=xlPasteValues
    ' usw.

(Beachte bitte, daß ich hier 4 Befehle in einer Zeile durch : getrennt habe.)

Wenn es kein Problem ist, daß auch das Format in die andere Mappe mit kopiert wird, dann geht das auch einfacher:

Code:

    s1.Range("[COLOR=#ff0000]d3[/COLOR]").Copy Destination:=s2.Range("[COLOR=#ff0000]g7"[/COLOR])
    s1.Range("[COLOR=#ff0000]d7[/COLOR]").Copy Destination:=s2.Range("[COLOR=#ff0000]g8"[/COLOR])
    s1.Range("[COLOR=#ff0000]a12[/COLOR]").Copy Destination:=s2.Range("[COLOR=#ff0000]g9"[/COLOR])
    ' usw.

Ok, dann muß da noch ein weiterer Schritt dazu und eine andere Syntax macht dann auch Sinn.

Zunächst muß festgestellt werden, welche die letzte belegte bzw. die daraus resultierende erste freie Zeile ist. Wenn die Zeilen in Spalte A einen Wert haben, kann man Spalte A also dafür heranziehen:

Code:

    dim y as long
    y = s2.cells(s1.rows.count,[COLOR=#ff0000]1[/COLOR]).end(xlup) + 1

Ich hab hier die "cells" Syntax gewählt, weil damit Zeilen und Spalten etwas sauberer getrennt sind. Es würde aber auch gehen:

Code:

    y = s2.range("[COLOR=#ff0000]a[/COLOR]" & s1.rows.count).end(xlup) + 1

Wenn jetzt mit "y" die freie Zeile bekannt ist, kann der "copy"-Befehl angepaßt werden:

Code:

    s1.Range("[COLOR=#ff0000]d3[/COLOR]").Copy Destination:=s2.Cells(y,[COLOR=#ff0000]7[/COLOR])
    s1.Range("[COLOR=#ff0000]d7[/COLOR]").Copy Destination:=s2.Cells(y,[COLOR=#FF0000]9[/COLOR])
    s1.Range("[COLOR=#ff0000]a12[/COLOR]").Copy Destination:=s2.Cells(y,[COLOR=#FF0000]13[/COLOR])
    ' usw.

Das würde jetzt der Reihe nach die Werte aus deinen gewünschten Bereichen / Zellen in die andere Mappe in die erste freie Zeile in die Spalten 7 (G), 9 (I), 13 (M) usw. kopieren.

Nix sorry, dafür ist ein Forum da! ;-)

Gruß, Michael

 

Hallo Michael
Vielen Dank für deine Antwort leider habe ich es noch immer nicht geschaft...

Hier ist mein Code der soweit gut funktioniert:
Private Sub CommandButton1_Click()

Private Sub CommandButton21_Click()
Const d = "M:"
Const p = "\üben\temp\"
Const x = ".xlsm"

Dim w1 As Workbook
Dim s1 As Worksheet
Dim r1 As Range
Dim w2 As Workbook
Dim s2 As Worksheet
Dim r2 As Range

Dim f As String
Dim dpfx As String

' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

f = Trim$(Range("d5").Value)
dpfx = d & p & f & x

On Error GoTo NoFile
Workbooks.Open dpfx
On Error GoTo 0

Set w1 = ThisWorkbook
Set s1 = w1.Worksheets("Maske")
Set r1 = s1.Range("A12:G12")

Set w2 = ActiveWorkbook
On Error GoTo NoSheet
Set s2 = w2.Worksheets("Tabelle1")
On Error GoTo 0
Set r2 = s2.Range("a3")


'a) kopiert mit Formaten, Formeln usw.
'On Error GoTo NoCopy
'r1.Copy Destination:=r2
'On Error GoTo 0

'b) kopiert ohne Formate usw., nur Werte
On Error GoTo NoCopy
r1.Copy
r2.PasteSpecial Paste:=xlPasteValues
On Error GoTo 0
Application.CutCopyMode = False

w2.Close savechanges:=True

' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

ExitSub:
Exit Sub

NoFile:
On Error GoTo 0
MsgBox "'" & dpfx & "' not found!"
Resume ExitSub

NoSheet:
On Error GoTo 0
MsgBox "Worksheet 'data' not found in '" & f & "'!"
Resume ExitSub

NoCopy:
On Error GoTo 0
MsgBox "copy failed!"
Resume ExitSub

End Sub

Und Dies ist meiene Excel wo es der reihe nach aulisten soll. auf dem Bild ist jetz zeille 3 gespeichert jetz möchte ich bei der nächsten "buchung"
Das es in zeille 4 Den eintrag macht oder eine Neue Zeille 3 Einfügt und die vor handen zeile 3 zur zeile 4 macht...


Hab schon fast ein Schlechtes Gewissen =(

Liebe Grüsse
Marcel

 

Moinsens!

Davon ist eine Zeile, und wahrscheinlich ist es die obere, zu viel. Wundert mich ein wenig, da der Debugger sich eigentlich über ein "Sub ohne End" beschweren müßte.

Code:

Dim r2 As Range

Setz da mal bitte folgende Zeile direkt unter:

Code:

dim y as long

Code:

Set r2 = s2.Range("a3")

Ändere das bitte in:

Code:

y = s2.cells(s2.rows.count,1).end(xlup) + 1
    Set r2 = s2.Range("a" & y)

Jetzt sollte er eigentlich aus der aktuellen Mappe vom Blatt "Maske" den Bereich A12:G12 in die neu geöffnete Mappe auf das Blatt "Tabelle1" in die erste freie Zeile ab Spalte A (umd demnach natürlich auch wieder bis Spalte G) kopieren.

Gruß, Michael

 

Hallo Michael
Mein Gewissen wird immer schlechter und zeigt mir auf was für ein anfänger ich bin...

Ich habe di änderungen so angebracht (hoffe das ich das alles richtig Verstanden habe)[
Nun wird eine Zeile gelb mit debugger LAufzeitfehler 13

Code:

Private Sub CommandButton21_Click()
 Const d = "M:"
    Const p = "\üben\temp\"
    Const x = ".xlsm"

    Dim w1 As Workbook
    Dim s1 As Worksheet
    Dim r1 As Range
    Dim w2 As Workbook
    Dim s2 As Worksheet
    Dim r2 As Range
    Dim y As Long
    Dim f As String
    Dim dpfx As String

' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    f = Trim$(Range("d5").Value)
    dpfx = d & p & f & x

    On Error GoTo NoFile
    Workbooks.Open dpfx
    On Error GoTo 0

    Set w1 = ThisWorkbook
    Set s1 = w1.Worksheets("Maske")
    Set r1 = s1.Range("A12:G12")

    Set w2 = ActiveWorkbook
    On Error GoTo NoSheet
    Set s2 = w2.Worksheets("Tabelle1")
    On Error GoTo 0
    
[B][COLOR="#FF0000"]    y = s2.Cells(s2.Rows.Count, 1).End(xlUp) + 1      IST GELB MIT  LAUFZEITFEHLER 13[/COLOR][/B]
    Set r2 = s2.Range("a" & y)
    

    'a) kopiert mit Formaten, Formeln usw.
    'On Error GoTo NoCopy
    'r1.Copy Destination:=r2
    'On Error GoTo 0

    'b) kopiert ohne Formate usw., nur Werte
    On Error GoTo NoCopy
    r1.Copy
    r2.PasteSpecial Paste:=xlPasteValues
    On Error GoTo 0
    Application.CutCopyMode = False

    w2.Close savechanges:=True

' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

ExitSub:
    Exit Sub

NoFile:
    On Error GoTo 0
    MsgBox "'" & dpfx & "' not found!"
    Resume ExitSub

NoSheet:
    On Error GoTo 0
    MsgBox "Worksheet 'data' not found in '" & f & "'!"
    Resume ExitSub

NoCopy:
    On Error GoTo 0
    MsgBox "copy failed!"
    Resume ExitSub

End Sub

Besten Herzlichsten Dank für deine Mühe

Freundliche Grüsse

Marcel

 

Moinsens!

Ey, verd... Ein kleines Wörtchen vergessen:

Code:

y = s2.Cells(s2.Rows.Count, 1).End(xlUp)[U][B].Row[/B][/U] + 1

Gruß, Michael

 

WOW!!!
Funktioniert einwand Frei...

Vielen TAUSEND DANK =)

Darf ich die ev noch mit einem Weiter problem Belästigen

 

Ich müsst jetz noch von der Tabbe 1 den von bis berich in Mappe 2 (z.B 9026) in spalt A unterinander auflisten.
z.B Tabelle 1
952-68-9026 50 Stück 51 - 100

Mappe 2
51
52
53
54
...
...

Wen aber dan eine Neue Liefeung gespeichert wird wird es immer fortlauend in die nächste lehre zeile kopiert.
Aktivierung kan zum beisbiel über ein Kästchen pro zeile erfolgen oder einen butten.. oder am schönsten natürlich automatisch es dar aber die vorhandenen daten nicht überschreiben...

Gruss
Marcel

P.S ich bin Wirklich mehr als ein Grünschnabel =(

 

Moinsens!

Immer raus damit... ;-) Aber ich bin mir nicht ganz sicher, ob ich die Frage in Deiner PM an mich richtig verstanden habe.

Stell die Frage aber auch sowieso ruhig gerne hier wieder. Dann haben wenigstens alle was davon.

Gruß, Michael

Edith sagt: Oha, da war die Frage ja schon...

 

Moinsens!

Also die letzte Fassung war doch, wenn ich mich recht entsinne, daß A12:G12 kopiert und in die andere Mappe in die erste freie Zeile geschrieben wird, richtig?

Wo steht denn da jetzt das "von" und "bis"? Es wäre keine Raketentechnik, da noch eine Schleife zu bauen, die von y ausgehend mehrere Zeilen schreibt.

Gruß, Michael

 

Hallo Michael
Also
Ich habe zum Beispiel im Ordener Rida ZH in Tabelle 1 die importierten Artikel 952-68-9024 von 5000 - 5010 Also 11 Stk
Nun möchte ich diese mit einem kästchen oder besser noch automatisch in die Tabelle 9024 der reihe nach untereinander azf listen

Freundliche Grüsse

Marcel

 

Moinsens!

Wo genau? Zeile+Spalte, Breite und Höhe des Bereichs?

Code:

die importierten Artikel 952-68-9024 von 5000 - 5010  Also 11 Stk

Was heißt das genau? Stehen da, wo auch immer, 11 Zellen nebeneinander, untereinander, eine Zelle mit der von-bis-Angabe? Wie kann das Makro erfahren, was von wo wohin kopiert werden soll? Und wenn ich das richtig verstanden habe, ist es ja nicht mal ein einfaches Kopieren, sondern eine mehrfache Kopie einer Zelle / Zeile, wobei irgendwas hochgezählt werden soll.

Code:

Nun möchte ich diese [...] in die Tabelle 9024 der reihe nach untereinander azf listen

Wie gesagt: Da fehlt noch ein bißchen Futter, in Form einer genaueren Beschreibung, in Form eines Screenshots oder in Form einer Beispiel-Tabelle.

Gruß, Michael