Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

vorhandenes Makro -> Autofilter leeren | Herbers Excel-Forum


Betrifft: vorhandenes Makro -> Autofilter leeren von: udo
Geschrieben am: 18.11.2009 12:49:58

Hallo zusammen, habe hier schoneinmal hervorragende Hilfe erhalten.
Es geht um mein Makro, welches Verschiedene Excel Listen in einer Gesamtübersicht zusammenführt.
Das ist mein Alter Thread:
https://www.herber.de/forum/archiv/1112to1116/t1114531.htm

Um diesen Code geht es.

Option Explicit

Const HomeDatei = "LeereArbeitsmappe.xls"    'Name Arbeitsmappe Makro-Excel-Datei
Const HomeDaten = "Import-Daten"          'Name Tabellenblatt Daten-Import
Const HomeListe = "Datei-Liste"           'Name Tabellenblatt Datei-Liste
Const HomeZeile = 3                       'Erste Zeile Einfügen
Const CopyZeile = 3                       'Erste Zeile Kopieren
Const ListDatei = "A1"                    'Zelle erster Dateiname
Const ErrMsg = "Abbruch! Datei existiert nicht: "

Sub SheetsImportS()              ' www.herber.de/forum/archiv/1112to1116/t1114531.htm
   Dim WksHome As Worksheet, WksList As Worksheet, EndLine As Long, NextLine As Long
   Dim WkbCopy As Workbook, WksCopy As Worksheet, Fso As Object, rngFile As Range
   Dim lngAnzZ As Long, lngSpA As Long, ii As Long, aStrU(), varU, lngU As Long

   Set WksHome = Workbooks(HomeDatei).Sheets(HomeDaten)
   Set WksList = Workbooks(HomeDatei).Sheets(HomeListe)

   EndLine = GetEndLine(WksHome)
   If EndLine >= HomeZeile Then WksHome.Rows("3:" & EndLine).ClearContents
   NextLine = HomeZeile
                        ' Titel aus Zeile 1 des Zielblatts in Array aStrU sammeln
   With WksHome
      lngSpA = .Cells(1, .Columns.Count).End(xlToLeft).Column
      If lngSpA > 1 Then
         aStrU = Application.Transpose(Application.Transpose( _
            .Cells(1, 1).Resize(, lngSpA)))
      ElseIf .Cells(1, 1) = "" Then
         MsgBox "Abbruch - Keine Spaltenüberschriften in Zeile 1 des Zielblatts"
         Exit Sub
      Else
         ReDim aStrU(1 To 1)
         aStrU(1) = .Cells(1, 1).Value2
      End If
   End With
'    Application.ScreenUpdating = False               ' NACH dem Test aktivieren
   Set Fso = CreateObject("Scripting.FileSystemObject")
   Application.EnableEvents = False

   For Each rngFile In WksList.Range(ListDatei).CurrentRegion
      If Fso.FileExists(rngFile) = False Then
         Application.ScreenUpdating = True
         MsgBox ErrMsg & rngFile, vbExclamation, "Fehler":  Exit Sub
      End If

      Set WkbCopy = Workbooks.Open(rngFile, False, True)       ' Quelle öffnen
      Set WksCopy = WkbCopy.Sheets(1)
      EndLine = GetEndLine(WksCopy)
      If EndLine >= CopyZeile Then
         lngAnzZ = EndLine - CopyZeile + 1      ' Anzahl zu kopierender Zeilen

         For ii = 1 To lngSpA                ' Spaltenüberschriften in Quelle suchen
            varU = Application.Match(aStrU(ii), WksCopy.Rows(1), 0)
            If IsNumeric(varU) Then
               lngU = varU                   ' wenn Treffer, Spalte kopieren
               WksHome.Cells(NextLine, ii).Resize(lngAnzZ) = _
                  WksCopy.Cells(CopyZeile, lngU).Resize(lngAnzZ).Value2
            End If
         Next ii
         NextLine = NextLine + lngAnzZ
      End If
      WkbCopy.Close SaveChanges:=False
   Next
   Application.EnableEvents = True
   Application.ScreenUpdating = True
End Sub

Private Function GetEndLine(ByRef Wks) As Long
   GetEndLine = Wks.Cells(Wks.Rows.Count, 1).End(xlUp).Row
End Function

Ich müsste hier noch eine Funktion einbauen, sodass die Autofilter in der 1. Zeile der Quell Dateien, woraus die Spalten kopiert werden, zurückgesetzt werden. Wenn jemand die Quelldatei speichert und vorher einen Filter gesetzt hat, werden ja nur die gefilterten Daten kopiert. Ich hoffe man versteht mein Problem und ihr könnt mir nocheinmal so kompetent wie zuvor helfen :) Vielen Dank

  

Betrifft: WksHome.ShowAllData oT von: IngGi
Geschrieben am: 18.11.2009 12:56:50

Hallo Udo,

das geht mit WksHome.ShowAllData.

Gruß Ingolf


  

Betrifft: AW: WksHome.ShowAllData oT von: udo
Geschrieben am: 18.11.2009 15:23:32

Hallo, danke. Habe nur das Problem, dass ich absoluter VBA Anfänger bin und leider nicht weiss, wo ich diesen Zusatz einfügen muss. Ich hoffe mir kann trotzdem geholfen werden :)


  

Betrifft: AW: vorhandenes Makro -> Autofilter leeren von: IngGi
Geschrieben am: 19.11.2009 01:01:20

Hallo Udo,

ich hab dir die Zeile mal an die relevante Stelle gepackt:

Set WksCopy = WkbCopy.Sheets(1)
WksCopy.ShowAllData
EndLine = GetEndLine(WksCopy)
Code eingefügt mit VBA in HTML 2.0.0.3

Gruß Ingolf


  

Betrifft: OT@IngGi : Glückwunsch zum Geburtstag ;-) von: NoNet
Geschrieben am: 19.11.2009 01:57:33

Happy Birthday, Ingolf !

Da hast Du doch glatt in Deinen Geburtstag hinein ge-Excelt :-)
Wünsche Dir einen schönen Tag,

Gruß NoNet


  

Betrifft: AW: OT@IngGi : Glückwunsch zum Geburtstag ;-) von: IngGi
Geschrieben am: 19.11.2009 12:26:46

Hallo NoNet,

danke für die Glückwünsche.

Gruß Ingolf


  

Betrifft: AW: vorhandenes Makro -> Autofilter leeren von: udo
Geschrieben am: 19.11.2009 08:51:26

Danke, klappt natürlich wieder hervorragend. Alles Gute auch von mir!


  

Betrifft: AW: vorhandenes Makro -> Autofilter leeren von: udo
Geschrieben am: 19.11.2009 15:40:04

Ein Problemchen habe ich noch gefunden:

Wenn bei den Quell-Daten der Autofilter nicht gesetzt ist, erhalte ich folgende Fehlermeldung:

Laufzeitfehler '1004':
Die Methode 'ShowAllData' für das Objekt '_Worksheet' ist fehlgeschlagen.


  

Betrifft: AW: vorhandenes Makro -> Autofilter leeren von: IngGi
Geschrieben am: 19.11.2009 16:54:09

Hallo Udo,

damit wird vorher geprüft, ob ein Filter gesetzt ist:

Set WksCopy = WkbCopy.Sheets(1)
If WksCopy.FilterMode Then WksCopy.ShowAllData
EndLine = GetEndLine(WksCopy)
Code eingefügt mit VBA in HTML 2.0.0.3

Gruß Ingolf


Beiträge aus den Excel-Beispielen zum Thema "vorhandenes Makro -> Autofilter leeren"