AW: Spalten aus einem Tabellenblatt auslesen
Kiewel
Hallo Thorsten,
sorry, Anfänger im Forum...
hier der Code:
Private Sub Workbook_Open()
Dim i As Long
Dim MC As String
Dim x As Integer
'Bläter umbenennen
Worksheets("Element 1").Name = "0_Anrufe"
Worksheets("Element 2").Name = "0_Gespräche"
'Basisdaten löschen
Application.DisplayAlerts = False
Sheets("Basisdaten").Select
ActiveWindow.SelectedSheets.Delete
'Zeilen Löschen
Sheets("0_Anrufe").Activate
Rows("1:11").Select
Selection.Delete shift:=xlUp
Sheets("0_Gespräche").Activate
Rows("1:11").Select
Selection.Delete shift:=xlUp
'Filter setzen
Sheets("0_Anrufe").Activate
If Not ActiveSheet.AutoFilterMode = True Then Range("A1").AutoFilter
Selection.AutoFilter field:=4, Criteria1:="Kundenbetreuung"
Sheets("0_Gespräche").Activate
If Not ActiveSheet.AutoFilterMode = True Then Range("A1").AutoFilter
Selection.AutoFilter field:=4, Criteria1:="Kundenbetreuung"
Sheets("0_Anrufe").Select
Range("A1:D701").Select
Selection.Copy
'Tabellenblätter einfügen
Application.ScreenUpdating = False
Sheets("0_Anrufe").Activate
Range("e1", Selection.End(xlToRight)).Select
For Each Zelle In Selection
Worksheets.Add 'Neues Tabellenblatt anlegen
ActiveSheet.Name = Zelle.Value 'Name aus Überschrift bilden
Range("A1").Select 'Zelle A1 aktivieren
ActiveSheet.Paste 'Einsetzen
Range("e1").Select 'Zelle E1 aktivieren
ActiveCell.FormulaR1C1 = "Anrufe" '"Anrufe reinschreiben
Range("f1").Select 'Zelle F1 aktivieren
ActiveCell.FormulaR1C1 = "Gespräche" '"Gespräche" reinschreiben
Range("d2:d29").Select 'Zellen d2-d29 aktivieren
ActiveCell.FormulaR1C1 = Zelle.Value 'MC Überschrift reinschreiben
Range("d3:d29").Value = Range("d2") 'in diese Zellen
Next Zelle
Application.ScreenUpdating = True
'Anruftabelle ohne Filter kopieren
Sheets("0_Anrufe").Activate
Cells.Select
Selection.Copy
Sheets.Add
Sheets("Tabelle28").Select
Sheets("Tabelle28").Name = "00_Anrufe"
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Gesprächtabelle ohne Filter kopieren
Sheets("0_Gespräche").Activate
Cells.Select
Selection.Copy
Sheets.Add
Sheets("Tabelle29").Select
Sheets("Tabelle29").Name = "00_Gespräche"
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Daten übertragen
Sheets("MC Amberg").Activate
For i = 2 To 29
''cells(Zeile, Spalte)
Range("E2:E29").Value = Sheets("00_Anrufe").Range("E2:E29").Value
Range("F2:F29").Value = Sheets("00_Gespräche").Range("F2:F29").Value
Next i
'Tabellenblätter sortieren
Application.ScreenUpdating = False
iMax = ActiveWorkbook.Worksheets.Count
For lbl = 1 To iMax
For ibl2 = lbl To iMax
If UCase(Worksheets(ibl2).Name) _
Ich hänge jetzt bei "Daten übertragen".
Eine Beispieldatei hänge ich dran.
https://www.herber.de/bbs/user/58095.xls
Beste Grüße
Peter