Zeilen einzeln durchgehen und abarbeiten...

Hallo zusammen,


ich habe folgendes Problem:


ich habe einen Code, mit dem ich mehrere Dateien öffnen und dann jeweils einen bestimmten Bereich in ein seperates Sheet kopieren kann. Das ist zwar schon ganz gut, jedoch nicht genau das, was ich brauche! =(

Die Sheets die eingelesen werden haben alle das selbe Muster! Der wichtigeste Bereich sind hier die Zellen B16 bis B30 und Q16 bis Q30 (Tätigkeit und dazugehörige Stunden).

Mein Makro soll nun (falls in dem Zellenbereich eine Tätigkeit mit mehr als 0 Stunden eingetragen ist) diese Tätigkeit in Spalte B meines seperaten Sheets übertragen. Die Stunden sollen in Spalte F eingetragen werden. (Wichtig ist einfach, dass nicht der komplette Spaltenbereich, sondern nur die mit Tätigkeit und Stunden gefüllten Zeilen übertragen werden).
Nun noch eine kleinigkeit. In jedem Sheet das eingelesen wird, steht in Zelle C6 ein Namenskürzel und in Zelle C2 die momentane Kalenderwoche! Wäre es möglich, dass bei jedem eingelesenen Sheet in die Spalte A der entsprechende Namenskürzel und in Spalte D die entsprechende Kalenderwoche übertragen wird.

--> ich hätte dann folgendes Muster für EIN eingelesenes Sheet mit 3 verschiedenen Tätigkeiten:

Spalte A: 3 x der Namenskürzel
Spalte B: 3 verschiedene Tätigkeiten
Spalte D: 3 x die Kalenderwoche
Spalte F: 3 x die zu den Tätigkeiten gehörenden Stunden

Wäre sowas möglich??? Hoffe ich konnte alles ausführlich erklären! Hab schon einiges versucht, aber komme nicht drauf. Ich nehmen an das muss irgendwie mit For-Schleifen und If Bedingungen gemacht werden...

Ich poste auch gleich mal den Code den ich bisher habe. Es müsste wohl nur der letzte Teil angepasst werden, da das vorherige einfach nur das Auswählen der Dateien ist.

Vielen herzlichen Dank im voraus! Wäre super wenn mir jemand helfen könnte! =) Bin langsam am Verzweifeln...

Beste Grüße,
RicoTumb


Sub DateiAuswaehlen()
\'modifiziert am 18.06.2008
Dim strdateiname, strAlleNamen As String
strdateiname = Dateiauswahl()
Dim n As Integer

If IsArray(strdateiname) Then \'Mehrere Dateien ausgewählt
\'Alle Namen in Eine Variable mit Zeilenumbruch zusammenfügen
strAlleNamen = Join(strdateiname, vbLf)
\'Anzeige der ausgewählten Dateinamen
If MsgBox(strAlleNamen, vbYesNo, \"Diese Dateein bearbeiten ?\") = vbYes Then
\'Alternativ : Zugriff auf einzelne Namen per Schleife :
For n = 1 To UBound(strdateiname)
\'MsgBox strDateiname(n), vbOKOnly, \"Datei Nr. \" & n
DateiBearbeiten strdateiname(n)
Next
End If
Else
If strdateiname <> \"\" Then DateiBearbeiten strdateiname
End If
End Sub

Function Dateiauswahl()
Dim strdateiname

\'Multiselect:=TRUE bedeutet : Es können mehrere Dateien ausgewählt werden
\'Multiselect:=FALSE bedeutet : Es kann nur EINE Datei ausgewählt werden
strdateiname = Application.GetOpenFilename( _
FileFilter:=\"Excel-Dateien (*.xls), *.xls\", _
Title:=\"Datei auswählen\", MultiSelect:=True)

If TypeName(strdateiname) = \"Boolean\" Then \'Abgebrochen
Dateiauswahl = \"\"
Else
Dateiauswahl = strdateiname
End If
End Function

Sub DateiBearbeiten(strdateiname)
Dim lngLZ As Long
Dim r1 As Range
Dim r As Range
Dim s As Worksheet

Set s = Sheets(\"Liste\")
Range(\"A1:IV1\") = \"Titel\"

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.Open strdateiname
With Workbooks(\"Auflistung.xls\").Sheets(\"Liste\")
lngLZ = .Cells(Rows.Count, 2).End(xlUp).Row \'letzte Zeile der Spalte B ermitteln
If lngLZ = 1 Then lngLZ = 0
Worksheets(2).Range(\"B16:B30\", \"Q16:Q30\").Copy \'aus erstem Tabellenblatt Bereich B16:B30 kopieren

Set r1 = .Cells(lngLZ + 1, 2)

r1.PasteSpecial Paste:=xlValues, skipblanks:=True \'Unterhalb letzte Zeile der Spalte B einfügen

End With

ActiveWorkbook.Close False
Application.ScreenUpdating = True

End Sub

Sub DateiBearbeiten(strdateiname)
Dim lngLZ As Long, i As Integer
Range("A1:IV1") = "Titel"  

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.Open strdateiname
With Workbooks("Auflistung.xls").Sheets("Liste")  
    lngLZ = .Cells(Rows.Count, 2).End(xlUp).Row 'letzte Zeile der Spalte B ermitteln  
    If lngLZ = 1 Then lngLZ = 0

    For i = 16 To 30 'Zeilen 16 bis 30 enthalten Daten  
        If Worksheets(2).Cells(i, "Q").Value > 0 Then 'Stundenzahl > 0  
            lngLZ = lngLZ + 1 'nächste Zeile in Zieltabelle verwenden  
            .Cells(lngLZ, "A") = Worksheets(2).Range("C6").Value   'Kürzel übertragen  
            .Cells(lngLZ, "B") = Worksheets(2).Cells(i, "B").Value 'Tätigkeit übertragen  
            .Cells(lngLZ, "D") = Worksheets(2).Range("C2").Value   'KW übertragen  
            .Cells(lngLZ, "F") = Worksheets(2).Cells(i, "Q").Value 'Stundenanzahl übertragen  
        End If
    Next

End With

ActiveWorkbook.Close False
Application.ScreenUpdating = True

End Sub