2 Arbeitsblätter exportieren VBA

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub IndikatorenExportieren() Dim dicIdentNo As Object Dim strIdentNo As String Dim arrIdentNo As Variant Dim lngLastRow As Long, i As Long Set dicIdentNo = CreateObject("Scripting.Dictionary") Dim wks As Worksheet 'AutoFilter in Spalte A einrichten For Each wks In Sheets(Array("Angest.", "Sonst.")) dicIdentNo.RemoveAll With wks .Columns("A:A").AutoFilter If Not .AutoFilterMode Then .Columns("A:A").AutoFilter End If 'Letzte Zeile ermitteln lngLastRow = .Cells(Rows.Count, 1).End(xlUp).Row 'Alle Indikator ermitteln For i = 2 To lngLastRow strIdentNo = Trim(.Cells(i, 1).Text) dicIdentNo(strIdentNo) = 0 Next i 'Alle Indikatoren in Array übertragen arrIdentNo = dicIdentNo.keys 'Jeden Indikator filtern und in neuer Arbeitsmappe speichern Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For i = 0 To UBound(arrIdentNo) .Cells(1, 1).AutoFilter Field:=1, Criteria1:=arrIdentNo(i) .Cells.SpecialCells(xlCellTypeVisible).Copy Workbooks.Add ActiveSheet.Paste Columns.AutoFit Range("A1").Select With ActiveWorkbook .SaveAs Filename:=ThisWorkbook.Path & "\" & wks.Name & "_" & arrIdentNo(i), FileFormat:=xlOpenXMLWorkbook .Close End With Next i End With Next wks Application.Calculation = xlCalculationAutomatic End Sub

Hallo,
dann:


Option Explicit
Sub IndikatorenExportieren()
Dim dicIdentNo As Object, oDic
Dim lngLastRow As Long, lngRow As Long
Dim wks As Worksheet, wkbNeu As Workbook
Dim arrSheets
Dim arrDaten
Set dicIdentNo = CreateObject("Scripting.Dictionary")
arrSheets = Array("Angest.", "Sonst.")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'AutoFilter in Spalte A einrichten
For Each wks In ThisWorkbook.Sheets(arrSheets)
With wks
.Columns(1).AutoFilter
If Not .AutoFilterMode Then
.Columns(1).AutoFilter
End If
'Letzte Zeile ermitteln
lngLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
'Alle Indikatoren ermitteln
For lngRow = 2 To lngLastRow
dicIdentNo(.Cells(lngRow, 1).Text) = 0
Next lngRow
End With
Next wks
'Jeden Indikator filtern und in neuer Arbeitsmappe speichern
For Each oDic In dicIdentNo
Set wkbNeu = Workbooks.Add(1)
ActiveSheet.Name = arrSheets(1)
wkbNeu.Worksheets.Add.Name = arrSheets(0)
For Each wks In ThisWorkbook.Sheets(arrSheets)
With wks
.Range("A1").AutoFilter Field:=1, Criteria1:=oDic
arrDaten = .Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible)
With wkbNeu.Sheets(wks.Name)
.Cells(1, 1).Resize(UBound(arrDaten), UBound(arrDaten, 2)) = arrDaten
.Columns.AutoFit
.Range("A1").Copy
.Range("A1").PasteSpecial xlPasteFormats
End With
End With
Application.CutCopyMode = False
Next wks
With wkbNeu
.SaveAs _
Filename:=ThisWorkbook.Path & "\" & Replace(ThisWorkbook.Name, ".xlsm", "") & "_" & oDic, _
FileFormat:=xlOpenXMLWorkbook
.Close
End With
Set wkbNeu = Nothing
Next oDic
Application.Calculation = xlCalculationAutomatic
End Sub

Gruß
Rudi

Sub M_snb() Sheets.Add , Sheets(Sheets.Count) With Tabelle1 .Columns(1).AdvancedFilter 2, , .Cells(1, 40), 1 With .Cells(1, 40).CurrentRegion sn = .Value .ClearContents End With With .Cells(1).CurrentRegion For j = 2 To UBound(sn) .AutoFilter 1, sn(j, 1) .Copy Sheets(Sheets.Count).Cells(1) .AutoFilter Sheets(Sheets.Count).Copy With ActiveWorkbook .SaveAs ThisWorkbook.Path & "\" & sn(j, 1), 51 .Close End With Sheets(Sheets.Count).UsedRange.Clear Next End With End With End Sub

Sub IndikatorenExportieren() Dim dicIdentNo As Object Dim ws As Worksheet Dim WB As Workbook Dim Dateiname As String Dim Elt, i 'Laufvariablen 'Alle Indikatoren eindeutig ermitteln Set dicIdentNo = CreateObject("Scripting.Dictionary") For Each ws In Sheets(Array("Angest.", "Sonst.")) ws.Columns("A:A").AutoFilter 'Reset Filter, 1 v. 2 If Not ws.AutoFilterMode Then ws.Columns("A:A").AutoFilter 'Reset Filter, 2 v. 2 'Dictionary aufbauen (Eindeutigkeit durch Dictionary-Schlüssel gewährleistet) For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row 'von Zeile 2 bis letzte Zeile dicIdentNo(Trim(ws.Cells(i, 1).Text)) = 0 Next i Next 'für jede eindeutige Eintrag For Each Elt In dicIdentNo.Keys 'als neue, spezifische Datei speichern Dateiname = Replace(ThisWorkbook.FullName, ".xls", "_" & Elt & ".xls") ThisWorkbook.SaveCopyAs Dateiname 'Datei öffnen Set WB = Workbooks.Open(Dateiname) 'in jeden Blatt Einträge löschen, die nicht relevante sind For Each ws In Sheets(Array("Angest.", "Sonst.")) For i = ws.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 'von letzte Zeile bis 2te (beim löschen, immer rückwärts) If Trim(ws.Cells(i, 1).Text) Elt Then ws.Rows(i).Delete Next Next 'spezifische Datei speichern und schliessen WB.Save WB.Close Next End Sub

Beliebteste Forumthreads (12 Monate)

2 Arbeitsblätter exportieren VBA

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread