Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1288to1292
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Einzelne Dateien erstellen

Einzelne Dateien erstellen
15.12.2012 17:12:25
Manu
Hallo Profis,
ich sitze schon seit Tagen an einem Problem, bekomme es aber nicht annähernd gelöst (vielleicht geht es auch gar nicht).
In meiner Datei gibt es unter anderem pro Arbeitstag ein Tabellenblatt (z.B. 01.10.2012, 02.10.2012 etc.). Innerhalb jedes Tagesplans stehen in den Zeilen 20 bis 32 Mitarbeiternamen.
Jetzt benötige ich ein Makro, dass für jeden Mitarbeiter, der in allen Tagesblättern in den Zeilen 20 bis 32 vorkommt, eine Datei erstellt, in der der Mitarbeiter alle seine Einsatzzeiten auf einem Blatt sehen kann. Innerhalb der neuen Datei soll in Zelle A1 der entsprechende Mitarbeitername stehen und die Datei soll ebenfalls nach seinem Namen benannt sein.
Zum besseren Verständnis habe ich meine Quelldatei sowie ein Beispiel des gewünschten Ergebnisses hochgeladen.
https://www.herber.de/bbs/user/83019.xls
https://www.herber.de/bbs/user/83020.xls
Ich hoffe, Ihr könnt mir weiterhelfen.
Grüße
Manuela

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Daten beim Einfügen transponieren
17.12.2012 18:17:00
Manu
Hallo Profis,
nachdem auf meine erste Anfrage leider keiner helfen konnte, habe ich etwas weiter gebastelt. Ich versuche gerade alle Tabellenblätter erst einmal auf ein Blatt zusammen zu kopieren. Das bekomme ich auch hin - allerdings möchte ich die kopierten Daten vor dem Einfügen transponieren und das will mir nicht gelingen. Vielleicht kann mir hierbei jemand helfen - BITTE.
Hier mein Code:

Sub Konsolidieren2()
'Konsolidierung ohne Überschriften ( Zeile 1 )
Dim Wks As Worksheet
Dim Bereich As Range
Dim strLC As String
Dim i As Integer
Set Wks = Worksheets.Add
Wks.Name = "Zusammenfassen"
For i = 6 To Worksheets.Count
With Worksheets(i).UsedRange
strLC = .Cells(.Rows.Count, .Columns.Count).Address
Set Bereich = .Range("A1:" & strLC)
Bereich.Copy
With Wks.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
.PasteSpecial , Paste:=xlPasteValuesAndNumberFormats
End With
End With
Next i
End Sub
Vielen Dank und Gruß
Manu

Anzeige
AW: Daten beim Einfügen transponieren
17.12.2012 18:18:36
Manu
hatte vergessen, als offen zu markieren :-)

AW: Daten beim Einfügen transponieren
17.12.2012 23:59:22
fcs
Hallo Manu,
hier Makros, die erst die Daten konsoliedieren und dann mit Hilfe des AUtofilters für eine Hilfssaplte die Daten zu den einzelnen Mitarbeitern in neue Arbitsmappen kopieren.
Gruß
Franz
Option Explicit
Private wksTag As Worksheet, wksMonat As Worksheet
Private wbkAktiv As Workbook, wbkMonat As Workbook, wksMA As Worksheet
Private SpalteTag As Long, Zeile_MA As Long, SpalteMonat As Long
Private Zeile_M As Long, Zelle As Range, Zelle_MA As Range
Sub MA_Monats_Dateien_erstellen()
Set wbkAktiv = ActiveWorkbook
Call Konsolidieren
Call MA_Dateien_erstellen(strPfad:=wbkAktiv.Path)  'Anpassen
Set wbkMonat = Nothing: Set wksMonat = Nothing
Set wbkAktiv = Nothing: Set wksMA = Nothing: Set wksTag = Nothing: Set Zelle = Nothing
End Sub
Private Sub Konsolidieren()
'Daten aus den Datumsblättern in ein Tabellenblatt übertragen
Application.ScreenUpdating = False
For Each wksTag In wbkAktiv.Worksheets
If IsDate(wksTag.Name) Then
If wbkMonat Is Nothing Then
'Monatsdatei und Monatsblatt anlegen
Application.Workbooks.Add Template:=xlWBATWorksheet
Set wbkMonat = ActiveWorkbook
Set wksMonat = wbkMonat.Worksheets(1)
wksMonat.Name = Format(CDate(wksTag.Name), "MMMM YY")
Set wksMA = wbkMonat.Worksheets.Add(after:=wksMonat)
wksMA.Name = "Liste_MA"
'Titel aus Spalte A des Tages ins Monatsblatt Zeile 2 kopieren
wksTag.Range("A1:A45").Copy
Zeile_M = 3 'Zeile mit Spaltentiteln im Monatsblatt
wksMonat.Cells(Zeile_M, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
'Spaltentitel Liste der MA
Zeile_MA = 1
With wksMA
.Cells(Zeile_MA, 1).Value = "MA-Name"
.Range("A2").Select
ActiveWindow.FreezePanes = True
End With
'Spaltenbreiten einstellen
With wksMonat
.Activate
.Columns(1).ColumnWidth = 6
.Columns(2).ColumnWidth = 8
.Columns(3).ColumnWidth = 10
.Columns(4).ColumnWidth = 12
.Range(.Columns(5), .Columns(6)).ColumnWidth = 14
.Range(.Columns(7), .Columns(8)).ColumnWidth = 12
.Columns(9).ColumnWidth = 20
.Range(.Columns(10), .Columns(13)).ColumnWidth = 10
.Columns(14).ColumnWidth = 7
.Range(.Columns(15), .Columns(16)).ColumnWidth = 11
.Columns(17).ColumnWidth = 9
.Columns(18).ColumnWidth = 4
.Columns(19).ColumnWidth = 8.5
.Range(.Columns(20), .Columns(32)).ColumnWidth = 13
.Range(.Columns(33), .Columns(38)).ColumnWidth = 15
.Range(.Columns(39), .Columns(40)).ColumnWidth = 5
.Columns(51).ColumnWidth = 11
.Columns(52).ColumnWidth = 5
.Columns(19).ColumnWidth = 8.5
.Range(.Columns(53), .Columns(55)).ColumnWidth = 15
Range("E4").Select
ActiveWindow.FreezePanes = True
End With
End If
With wksTag
'Letzte Spalte mit Daten in Zeile 1
SpalteTag = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(1, 2), .Cells(45, SpalteTag)).Copy
End With 'wksTag
With wksMonat
'nächste freie Zeile im Monatsblatt in Spalte A
Zeile_M = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(Zeile_M, 1).PasteSpecial Paste:=xlPasteFormats, Transpose:=True
.Cells(Zeile_M, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
'Mitarbeiterliste auffüllen
With wksTag
For Each Zelle In wksTag.Range(.Cells(20, 2), .Cells(32, SpalteTag)).Cells
If Zelle.Value  "" Then
With wksMA
Set Zelle_MA = .Columns(1).Find(what:=Zelle.Text, LookIn:=xlValues, lookat:=xlWhole) _
If Zelle_MA Is Nothing Then
Zeile_MA = Zeile_MA + 1
.Cells(Zeile_MA, 1).Value = Zelle.Text
End If
End With
End If
Next Zelle
End With
End If
Next wksTag
With wksMonat
'Auswerteformeln für MA in Hilfsspalte einfügen
SpalteMonat = .Cells(3, .Columns.Count).End(xlToLeft).Column + 1
.Cells(3, SpalteMonat) = "Hilfs-Spalte"
Zeile_M = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(4, SpalteMonat), .Cells(Zeile_M, SpalteMonat)).FormulaR1C1 _
= "=IF(COUNTIF(RC20:RC32,R1C1)>0,""X"","""")"
End With
With wksMA
'Liste der Mitarbeiternamen sortieren
With .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
If .Rows.Count > 2 Then
.Sort key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes
End If
End With
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Private Sub MA_Dateien_erstellen(ByVal strPfad As String)
'Erstellt für jeden Mitarbeiter eine Datei mit den Monatsdaten im Verzeichnis strPfad
Dim wbkMA As Workbook, wksMuster As Worksheet
'  Set wbkMonat = ActiveWorkbook
'  Set wksMA = wbkMonat.Worksheets("Liste_MA")
'  Set wksMonat = wbkMonat.Worksheets("Monat")
'Mustervorlage erstellen
wksMonat.Copy after:=wksMA
Set wksMuster = ActiveSheet
With wksMuster
.Range(.Cells(4, 1), .Cells(.Rows.Count, 1).End(xlUp)).EntireRow.Delete
.Name = "Monatsdaten"
.Cells(3, 46).Clear
End With
With wksMonat
Zeile_M = .Cells(.Rows.Count, 46).End(xlUp).Row
'in der Hilfsspalte den Autofilter einrichten
.Range(.Cells(3, 1), .Cells(Zeile_M, 46).End(xlUp)).AutoFilter
For Zeile_MA = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
'nächsten Namen aus Liste eintragen
.Range("A1") = wksMA.Cells(Zeile_MA, 1).Value
.Calculate
'Autofilter für Spalte 46 setzen
.AutoFilter.Range.AutoFilter Field:=46
.AutoFilter.Range.AutoFilter Field:=46, Criteria1:="X"
'Musterblatt in neue Mappe kopieren, gefilterte Daten kopieren und Datei speichern
wksMuster.Copy
Set wbkMA = ActiveWorkbook
.Range(.Cells(1, 1), .Cells(Zeile_M, 45)).Copy Destination:=wbkMA.Worksheets(1).Cells(1,  _
1)
Application.DisplayAlerts = False
wbkMA.SaveAs Filename:=strPfad & "\" & wksMA.Cells(Zeile_MA, 1).Value & ".xls", _
FileFormat:=xlWorkbook
Application.DisplayAlerts = True
wbkMA.Close
Next
.ShowAllData
.AutoFilterMode = False
End With
End Sub

Anzeige
Du bist Spitze
18.12.2012 17:56:06
Manu
Hallo Franz,
das ist ja der Wahnsinn :-) Erst mal tausend Dank für Deine Mühe. Wenn ich den Code so sehe, weiß ich, dass ich das in 100 Jahren nicht hinbekommen hätte.
Leider bekomme ich ziemlich am Schluss des Makros noch eine Fehlermeldung. Kannst Du mir dabei bitte nochmal helfen.
Laufzeitfehler 104: Die Methode 'SaveAs' für das Objekt Workbook ist fehlgeschlagen.
Hier stoppt es. Vorher werden aber alle Mitarbeiterdateien abgespeichert.
wbkMA.SaveAs Filename:=strPfad & "\" & wksMA.Cells(Zeile_MA, 1).Value & ".xls", _
FileFormat:=xlWorkbook
Lieben Gruß
Manu

Anzeige
AW: Dateiname prüfen
18.12.2012 20:34:18
fcs
Hallo Manu,
wahrscheinlich enthält der Mitarbeitername beim Fehler ein für Dateinamen unzulässiges oder ungünstiges Zeichen.
Ich hab die Speicherroutine um entsprechende Prüfungen ergänzt und solche Zeichen im Namen werden durch ein "_" ersetzt.
Wenn ich den Code so sehe, weiß ich, dass ich das in 100 Jahren nicht hinbekommen hätte.
Ich bin noch keine 60. Du kannst also noch hoffen, das es bei entsprechendem Training früher mit der VBA-programmierung funktioniert.
Gruß
Franz
Private Sub MA_Dateien_erstellen(ByVal strPfad As String)
'Erstellt für jeden Mitarbeiter eine Datei mit den Monatsdaten im Verzeichnis strPfad
Dim wbkMA As Workbook, wksMuster As Worksheet, strMA As String
On Error GoTo Fehler
'Mustervorlage erstellen
wksMonat.Copy after:=wksMA
Set wksMuster = ActiveSheet
With wksMuster
.Range(.Cells(4, 1), .Cells(.Rows.Count, 1).End(xlUp)).EntireRow.Delete
.Name = "Monatsdaten"
.Cells(3, 46).Clear
End With
With wksMonat
Zeile_M = .Cells(.Rows.Count, 46).End(xlUp).Row
'in der Hilfsspalte den Autofilter einrichten
.Range(.Cells(3, 1), .Cells(Zeile_M, 46).End(xlUp)).AutoFilter
For Zeile_MA = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
strMA = wksMA.Cells(Zeile_MA, 1).Value
'Prüfen, ob Name nur aus Leerzeichen besteht
If Trim(strMA)  "" Then
'nächsten Namen aus Liste eintragen
.Range("A1") = strMA
.Calculate
'Autofilter für Spalte 46 setzen
.AutoFilter.Range.AutoFilter Field:=46
.AutoFilter.Range.AutoFilter Field:=46, Criteria1:="X"
'Musterblatt in neue Mappe kopieren, gefilterte Daten kopieren und Datei speichern
wksMuster.Copy
Set wbkMA = ActiveWorkbook
.Range(.Cells(1, 1), .Cells(Zeile_M, 45)).Copy Destination:=wbkMA.Worksheets(1).Cells(1, _
1)
Application.DisplayAlerts = False
wbkMA.SaveAs Filename:=strPfad & "\" & CheckFileName(strMA) & ".xls", _
FileFormat:=xlWorkbook
Application.DisplayAlerts = True
wbkMA.Close
End If
Next_MA:
Next
.ShowAllData
.AutoFilterMode = False
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
MsgBox "Mitarbeiter-Name: " & strMA & vbLf _
& "Fehler-Nr.: " & .Number & vbLf & .Description
.Clear
Application.DisplayAlerts = True
Resume Next_MA
End Select
End With
End Sub
Private Function CheckFileName(strText As String) As String
'ersetzt nicht zulässige/ungünstige Zeichen im Namen durch "_"
Dim intZeichen As Integer
For intZeichen = 1 To Len(strText)
Select Case Mid(strText, intZeichen, 1)
Case ":", "?", "/", "\", "", "[", "]", "*", "|"
CheckFileName = CheckFileName & "_"
Case Else
CheckFileName = CheckFileName & Mid(strText, intZeichen, 1)
End Select
Next
End Function

Anzeige
AW: Dateiname prüfen
19.12.2012 18:49:30
Manu
Hallo Franz,
jetzt funktioniert alles ohne Fehlermeldung. Nochmals vielen vielen Dank.
Ich werde mir jede Codezeile genau ansehen, damit ich irgendwann selbst so etwas bauen kann.
Ich wünsche Dir ein frohes Fest und viele Geschenke unterm Weihnachtsbaum.
Viele Grüße
Manu

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige