AW: Werte vergleichen und in Arbeitsmappe übertragen
29.08.2011 06:41:40
fcs
Hallo damicl,
ich hab Tino's Lösung mal in deine gewünschte Richtung angepasst.
Alle Informationen die du schon ermittelt hast werden als Parameter an die Prozedur übergeben, die die Daten in das Lohnabrechnungsblatt des jeweiligen Mitarbeiters überträgt.
Die Tatsache, dass pro Tag ein Blatt ausgefüllt wird macht es natürlich noch etwas komplizierter.
Das was in Auftragsdaten_Einlesen steht muss du in geeignter Form in dein vorhandenes Makro einbauen.
Falls du unbedingt mit deinen Variablen A3, A4, bis A20 arbeiten willst, dann muss du den Code innerhalb der For-Next-Schleife 18-mal kopieren und arrName(iIndex) jeweils durch die Variable ersetzen.
Gruß
Franz
Sub Auftragsdaten_Einlesen()
Dim vAktuellerMonat, vAktuellesJahr, arrName(3 To 20) As String
Dim iIndex As Integer
Dim wbAuftrag As Workbook, wksAuftrag As Worksheet
'Statt mit Variablen A3,A4,...,A20 zu arbeiten ist es einfacher ein Daten-Array abzuarbeiten
arrName(3) = "MeierB"
arrName(4) = "MeierA"
arrName(5) = "Schulze"
arrName(6) = "Özdemir"
'usw.
'Arbeitsmappe in der die auszulesenden Daten stehen
With Application.FileDialog(msoFileDialogOpen)
.Title = "Bitte Datei mit Auftragsdaten öffnen"
If .Show = False Then Exit Sub
Workbooks.Open Filename:=.SelectedItems(1), ReadOnly:=True
End With
Set wbAuftrag = ActiveWorkbook 'oder = Workbooks("Auftrag") 'Anpassen!!
'Tabellenblatt in dem die auszulesenden Daten stehen
Set wksAuftrag = wbAuftrag.Worksheets(1) 'oder auch = wbAuftrag.Worksheets("Erfassung")
vAktuellerMonat = "08"
vAktuellesJahr = "2011"
For iIndex = LBound(arrName) To UBound(arrName)
Application.StatusBar = "Bearbeite Stundenabrechnung für " & arrName(iIndex)
Call Daten_nach_Lohnabrechnung(sName:=arrName(iIndex), sJahr:=vAktuellesJahr, _
sMonat:=vAktuellerMonat, wksQuelle:=wksAuftrag)
Next
Application.StatusBar = False
wbAuftrag.Close savechanges:=False
End Sub
Sub Daten_nach_Lohnabrechnung(sName As String, ByVal sJahr As String, _
ByVal sMonat As String, wksQuelle As Worksheet)
Dim Zelle As Range
Dim oWBEx As Workbook, strPath$, strDatei$, vSheet
Dim iCalc%
If sName = "" Then GoTo Beenden
'Verzeichnis in dem die Dateien für die einzelnen Mitarbeiter stehen - anpassen
strPath = "C:\Users\Public\Test\01\"
'Zellen mit Namen im Quelltabellenblatt abarbeiten - Bereich ggf. anpassen
For Each Zelle In wksQuelle.Range("C16:C30")
If Zelle.Value = sName Then
If oWBEx Is Nothing Then
strDatei = "Lohnabrechnung " & sName & " " & sMonat & " " & sJahr & ".xlsx"
'Prüfen, ob Datei für Mitarbeiter vorhanden
If Dir(strPath & strDatei) = "" Then
MsgBox "Der Dateiname """ & strPath & strDatei & """ existiert nicht!"
Exit For
End If
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Set oWBEx = Workbooks.Open(strPath & strDatei) 'Datei öffnen
End If
'Index-Nr. oder Blattname des Tabellenblatts für den Tag aus dem Datum in _
Spalte B (2) ermitteln - hier sind Blatt 1 die Übersicht und Blatt 2 bis 32 _
die Blätter für die Tage 1 bis 31
vSheet = Day(wksQuelle.Cells(Zelle.Row, 2)) + 1 ' - ggf. anpassen
With oWBEx.Sheets(vSheet)
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(, 15).Value = _
wksQuelle.Cells(Zelle.Row, 1).Resize(, 15).Value
End With
End If
Next Zelle
Beenden:
If Not oWBEx Is Nothing Then
oWBEx.Close savechanges:=True 'Datei speichern + schließen
With Application
.Calculation = iCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub