Bestimmte Daten suchen und in Tablen kopieren

Computer: Software & Programmierung Visual Basic
#1

Hallo ich habe folgendes Problem.
Ich habe eine Mastertabelle aus welcher nur bestimmte Datensätze kopiert werden sollen und in andere bestimmte Excel Datei kopiert werden sollen.
Bsp.

Mastertabelle:

Land Vertreter Projekt …

China Mr.Chi X1 …
India Mr.Ind X2 …
Russia Mr.Rus X3 …
China Mr.Chi X4 …
China Mr.Chi X5 …
Russia Mr.Rus X6 …
… … … …
…
…

Es sollen dann nur die Datensätze kopiert werden die zu China, Indien, Russland… dazugehören und nur in die entsprechenden Dateien gespeichert werden.
Eine zusätzliche Anforderung ist es, dass die Mastertabelle jeden Tag geändert wird. Es soll also beim Öffnen der Datei z.B. China.xls die Mastertabelle nach den dazugehörigen Daten durchsucht werden und in die China.xls kopiert werden. Dasselbe soll mit den anderen Dateien geschehen. Hat jemand eine Idee wie dieses Problem gelöst werden kann???

#2

Es sollen dann nur die Datensätze kopiert werden die zu China,
Indien, Russland… dazugehören und nur in die entsprechenden
Dateien gespeichert werden.
Eine zusätzliche Anforderung ist es, dass die Mastertabelle
jeden Tag geändert wird. Es soll also beim Öffnen der Datei
z.B. China.xls die Mastertabelle nach den dazugehörigen Daten
durchsucht werden und in die China.xls kopiert werden.

Hallo Johnny,

kommst du mit Code einfügen klar?
Übe an Kopien der Mappen.
Originalmappen sicherheitshalber woanderst abspeichern.

Option Explicit
'
Sub Kopier()
Dim wksM As Worksheet
Dim wks As Worksheet, W As Integer, ZeiM As Long, Zei As Long
Application.ScreenUpdating = False
Set wksM = Workbooks("Master").Worksheets("Tabelle1")
Set wks = ThisWorkbook.Worksheets("Tabelle1")
wks.Activate
With wksM
 ZeiM = .Cells(Rows.Count, 1).End(xlUp).Row
 Zei = Cells(Rows.Count, 1).End(xlUp).Row
 wks.Range("S1:T1") = Split("Land Name Projekt")
 wks.Range("S2") = Replace(ThisWorkbook.Name, ".xls", "")
 .Range("A1:C" & Zei).AdvancedFilter Action:=xlFilterCopy, \_
 CriteriaRange:=wks.Range("S1:T2"), CopyToRange:=wks.Cells(Zei + 1, 1), Unique:=False
 wks.Range("S1:T2").ClearContents
End With
Application.ScreenUpdating = True
End Sub

Gruß
Reinhard

#3

Hallo Reinhard,

ich kenne mich nur gering mit VBA aus. Es sieht schon sehr ähnlich dem was ich brauche. Verstehe aber nicht ganz die einzelnen Zeilen des Quelltextes. Die von mir als Beispiel genannten Daten sind nur ein Teil der Tabelle. Es sind eingehende Projekte die zunächst alle in einer Excel Datei gespeichert werden. Sollen aber danach zu separaten Excel Dateien gesplittet werden und nur bestimmte Datensätze eines Landes. z.B. nur die Daten in den Spalten [A;C;D;G…] des Landes China. Also wenn in der Spalte H (Land) China steht, sollen die Datensätze aus den Spalten [A;C;D;G…] kopiert werden und in die Datei Chnia.xls eingefügt werden. Hast du eine Idee dazu? Könnte man das auch mit SVerweis hinbekommen oder sind die Funktionen in diesem Fall nicht ausreichend?

Danke im Voraus.

#4

ich kenne mich nur gering mit VBA aus. Es sieht schon sehr
ähnlich dem was ich brauche. Verstehe aber nicht ganz die
einzelnen Zeilen des Quelltextes. Die von mir als Beispiel
genannten Daten sind nur ein Teil der Tabelle. Es sind
eingehende Projekte die zunächst alle in einer Excel Datei
gespeichert werden. Sollen aber danach zu separaten Excel
Dateien gesplittet werden und nur bestimmte Datensätze eines
Landes. z.B. nur die Daten in den Spalten [A;C;D;G…] des
Landes China. Also wenn in der Spalte H (Land) China steht,
sollen die Datensätze aus den Spalten [A;C;D;G…] kopiert
werden und in die Datei Chnia.xls eingefügt werden. Hast du
eine Idee dazu? Könnte man das auch mit SVerweis hinbekommen
oder sind die Funktionen in diesem Fall nicht ausreichend?

hallo Johny,

erstelle mal eine master.xls, die exaktgleiche Spaltenbeschriftung wie im Original hat.
Die kannste auch schicken, aber mir langen da 20-30 Zeilen, brauch keine 50.000.
Hochladen mit rapidshare, siehe FAQ:2606

Mein Code ist zwar ungetestet, müßte aber weitgehend das machen was du willst.

Gruß
Reinhard

#5

Aus Datenschutz kann ich leider keine Daten hochladen.
Mir würde se schon helfen wenn du deinen Quelltext auskommentieren könntest, damit ich weiß was im Einzelnen geschieht und diesen dann an meine Daten anpassen kann.

Vielen Dank.

#6

Aus Datenschutz kann ich leider keine Daten hochladen.
Mir würde se schon helfen wenn du deinen Quelltext
auskommentieren könntest, damit ich weiß was im Einzelnen
geschieht und diesen dann an meine Daten anpassen kann.

Hallo Johny,

ich hab noch einen kleinen Bug entdeckt und zerquetscht.

Mein Code benutzt den Spezialfilter in Excel, da kann man nur zusammenhängende Spalten rüberkopieren, aber kein Akt, nicht erwünschte Spalten kann man im Code dann löschen, ich muß nur wissen welche.

Mein Code überprüft nur im Masterdokument die Spalte A, wenn dort Der Mappename von China.xls ohne dieses .xls auftaucht, werden Ax-Cx rüberkopiert.
S1:U2 sind nur Hilfszellen. Nimmt man halt andre wenn da schon was steht.

Sub Kopier()
Dim wksM As Worksheet, wks As Worksheet, W As Integer, ZeiM As Long, Zei As Long
Application.ScreenUpdating = False ' Bidschirmaktualisierung aus
'Mit wks und wksM kann man dann die enstprechenen Blätter referenzieren/ansprechen
Set wksM = Workbooks("Master.xls").Worksheets("Tabelle1")
Set wks = ThisWorkbook.Worksheets("Tabelle1")
wks.Activate
With wksM
 ' Ermittlung der zeile der untersten befüllten Zelle in A von wksM
 ZeiM = .Cells(Rows.Count, 1).End(xlUp).Row
 ' Ermittlung der zeile der untersten befüllten Zelle in A von wks
 Zei = Cells(Rows.Count, 1).End(xlUp).Row
 'S1="Land", T1="Name", U1 ="Projct"
 wks.Range("S1:U1") = Split("Land Name Projekt")
 'S2 ist "China" wenn die Mappe China.xls heißt.
 wks.Range("S2") = Replace(ThisWorkbook.Name, ".xls", "")
 'Der nächste Befehl entspricht Daten Spezialfilter
 'wenn du dort "an eine andere Stelle kopieren" auswählst
 'Listenbereich: wksM.Range("A1:C" & Zei)
 'Kriterienbereich: wks.Range("S1:U2")
 'Kopieren nach wks.Cells(Zei + 1, 1)
 .Range("A1:C" & Zei).AdvancedFilter Action:=xlFilterCopy, \_
 CriteriaRange:=wks.Range("S1:U2"), CopyToRange:=wks.Cells(Zei + 1, 1), Unique:=False
 'Kriterienbereich löschen
 wks.Range("S1:U2").ClearContents
End With
Application.ScreenUpdating = True ' Bidschirmaktualisierung ein
End Sub

Gruß
Reinhard

#7

http://rapidshare.com/files/363701854/Master1.xls.html

Ich habe eine abgespeckte Version der Master hochgeladen.
Es soll in dem Bereich J „Host Country“ suchen und wenn zum Beispiel „China“ in der Spalte J3 steht, dann sollen „Client“, „Project“ und „Starting Date“ aus der Zeile 3 in die Datei China kopiert werden. Jedoch alle Projekte die in China sind in die China.xls also auch die Zeilen 7 und 8. Dasselbe soll für jedes andere Land auch gemacht werden. Also Deutschland, Indien usw.
Dein Text kopiert mir nur den Dateinamen in die Tabelle. Also wenn ich die Datei China.xls aufrufe und das Makro starte, fügt er „China“ in die Tabelle ein.

Hoffe habe mein Problem diesmal besser dargestellt.

Danke im Voraus

#8

http://rapidshare.com/files/363701854/Master1.xls.html

Ich habe eine abgespeckte Version der Master hochgeladen.
Es soll in dem Bereich J „Host Country“ suchen und wenn zum
Beispiel „China“ in der Spalte J3 steht, dann sollen „Client“,
„Project“ und „Starting Date“ aus der Zeile 3 in die Datei
China kopiert werden.

Hallo Johny,

alles lösbar.

nimm mal den nacstehenden Code in die China.xls.

Mal völli weglassen daß du da nicht alle Spalten haben willst, das löse ich später, müßte er funktioniern, da getestet.

Äh, meine Kommentare im Code stummen nicht mehr, mußt du anpassen.
S1:U1 ist jetzt S1:AB1 usw.

Da du ja grundsätzlich dateien hochladen darfst, lade die China.xls hoch, wenn du nicht klarkommst.

Sub Kopier()
Dim wksM As Worksheet, wks As Worksheet, W As Integer, ZeiM As Long, Zei As Long
Application.ScreenUpdating = False ' Bidschirmaktualisierung aus
'Mit wks und wksM kann man dann die enstprechenen Blätter referenzieren/ansprechen
Set wksM = Workbooks("Master1.xls").Worksheets("Projects")
Set wks = ThisWorkbook.Worksheets("Tabelle1")
wks.Activate
With wksM
 ' Ermittlung der zeile der untersten befüllten Zelle in A von wksM
 ZeiM = .Cells(Rows.Count, 1).End(xlUp).Row
 ' Ermittlung der zeile der untersten befüllten Zelle in A von wks
 Zei = Cells(Rows.Count, 1).End(xlUp).Row
 If Zei = 1 Then Zei = 0
 wksM.Range("A1:J1").Copy Destination:=wks.Range("S1:AB1")
 'S2 ist "China" wenn die Mappe China.xls heißt.
 wks.Range("AB2") = Replace(ThisWorkbook.Name, ".xls", "")
 'Der nächste Befehl entspricht Daten Spezialfilter
 'wenn du dort "an eine andere Stelle kopieren" auswählst
 'Listenbereich: wksM.Range("A1:C" & Zei)
 'Kriterienbereich: wks.Range("S1:U2")
 'Kopieren nach wks.Cells(Zei + 1, 1)
 .Range("A1:J" & ZeiM).AdvancedFilter Action:=xlFilterCopy, \_
 CriteriaRange:=wks.Range("S1:AB2"), CopyToRange:=wks.Cells(Zei + 1, 1), Unique:=False
 'Kriterienbereich löschen
 If Zei 0 Then wks.Rows(Zei + 1).Delete
 wks.Range("S1:AB2").Clear
End With
Application.ScreenUpdating = True ' Bidschirmaktualisierung ein
End Sub

Gruß
Reinhard

#9

Funktioniert super, vielen Dank. Freut mich sehr, dass es klappt. Danke nochmals.

Beste Grüße Johny

#10

Hallo Reinhard,
das Skript funktioniert soweit sehr gut, jetzt will ich nur bestimmte spalten in meine neue Datei z.B. „China.xls“ übernehmen. Bis jetzt kopiert das Programm nur den ausgewählten Bereich z.B. „A1:N1“. Brauche aber nur die Daten dazwischen z.B. die Spalten „A, C, E, H“ und den Bereich „L:N“ . Hast du eine Idee wie man das hinbekommt?