Hilfe: Excel Zeilen kopieren
23.06.2005 09:36:29
philipp
ich muß gestehen, dass ich diesen Thread hier eigentlich zum zweitenmal aufmachen, aber der ist jetzt so weit runter gerutscht und ich habe bis jetzt noch keine Anwort bekommen die mir hilft, dass ich es jetzt noch mal weiter oben Probiere
Zum Sachverhalt:
Ich habe circa vier bis fünf Arbeitsmappen. Jede Arbeitsmappe gehört einem Teammitglied in denen er seine Aufgabenliste(Aufgabenliste_NAME.xls) in die Tabelle1 reinschreibt. Die Liste in Tabellenform fängt in den Zeilen A7 bis F7 an und ist je nachdem wieviel das Teammitglied zu tun hat etwas länger oder kürzer (Die Aufgabenliste braucht also mehr oder weniger Zeilen). Alle Teamlisten möchte ich in eine andere Arbeitsmappe (Aufgabenliste_Team.xls) kopieren lassen. Diese Arbeitsmappe beinhaltet zwei Tabellen. Die erste Tabelle heißt Aufgaben. In der Tabelle Aufgaben ist ein Button auffüllen, wenn man drauf klickt dann soll sich alle Aufgabenlisten der Teammitglieder reinzukopieren und zwar auch ab der Spalte A7 bis F7 reinkopiert werden. In der zweiten Tabelle mit dem Namen Team stehen alle Namen der Teammitglieder drin.
Mein derzeitiger Code sieht so aus.
Option Explicit
Private Sub btauffuellen_Click()
Dim zielDatei As Workbook
Dim quellDatei As Workbook
Dim dateiName As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim aufgabenVorhanden As Boolean
Dim aufgaben As Variant
Dim aufgabenPunkte() As Variant
Set zielDatei = ActiveWorkbook
'Abschalten der Warnmeldungen und der Screenaktualisierung
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Bereinigen der Zieldatei
zielDatei.Sheets("Aufgaben").Select
ActiveSheet.Range("A7:I200").Delete
'Auslesen der Dateinamen, die ausgelesen werden sollen
Sheets("Team").Select
Sheets("Team").Range("A1").Select
Do Until ActiveCell.Value = ""
dateiName = ActiveCell.Value
ActiveCell.Offset(1, 0).Select
If Dir(ThisWorkbook.Path & "\aufgaben_" & dateiName & ".xls") = "" Then
MsgBox ("Die Datei & aufgaben_ & dateiName & .xls liegt nicht in dem gleichen Verzeichnis wie die Zieldatei"), vbCritical, "Datenbank nicht gefunden!"
Exit Sub
Else
Workbooks.Open Filename:=ThisWorkbook.Path & "\aufgaben_" & dateiName & ".xls"
End If
'Aktivierung der Quelldatei
Set quellDatei = ActiveWorkbook
ActiveSheet.Range("F6").Select
aufgabenVorhanden = False
'Wenn Aufgaben vorhanden sind
If ActiveCell <> "" Then
aufgabenVorhanden = True
Do Until ActiveCell = "" And i > 30
aufgabenPunkte(i, k) = ActiveCell.Value
i = 5
i = i + 1
For k = 1 To 5 Step 1
k = k + 1
Next k
Loop
End If
'Nach dem Auslesen der Aufgaben
quellDatei.Close
j = 0
zielDatei.Sheets("Aufgaben").Select
If aufgabenVorhanden Then
ActiveCell.Value = dateiName
ActiveCell.Offset(2, 0).Select
Do Until j >= i
Loop
End If
Loop
zielDatei.Sheets("Aufgaben").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Besonders sorgen macht mir dieser Teil des Codes. Hier wollte ich eigentlich die Spalte A bis F in ein zweidimensionales Array schreiben. Aber erst ab der Zeile 7 bis zu der Zeile in der die Tabelle leer ist. So ich hoffe ich habe das jetzt einigermaßen erklärt.
If ActiveCell <> "" Then
aufgabenVorhanden = True
Do Until ActiveCell = "" And i > 30
aufgabenPunkte(i, k) = ActiveCell.Value
i = 5
i = i + 1
For k = 1 To 5 Step 1
k = k + 1
Next k
Loop
End If
Liebe Grüße Philipp