Zellbereich prüfen, ob Inhalt vorhanden ist
01.02.2017 07:31:27
Matze
ein paar grundlegende Erfahrungen mit VBA habe ich schon gemacht, so dass ich das ein oder andere Verstehe, wenn ich einen Code sehe. Zum selber programmieren ist es aber noch ein weiter Weg und hoffe so auf eure Hilfe.
Ich habe ein Makro, mit dem ich mehrere Tabellen in einer zusammenfasse. Die auszulesenden Dateien sind alle identisch aufgebaut.
Für das Auslesen und Zusammenfassen habe ich bereits im Netz einen Codeschnipsel von Jürgen Hennekes gefunden. Das funktioniert soweit auch ganz gut mit einer kleinen Ausnahme und hier hoffe ich auf eure Hilfe!
Teilweise ist in dem auszulesenden Tabellenblatt außer der Überschrift nichts eingetragen. Ist das der Fall kopiert mein Makro die Überschrift, obwohl der Bereich ausgeschlossen ist. Ich vermute das liegt daran, dass die letzte leere Zeile -1 gesucht wird.
Nun möchte ich gerne vor dem kopieren prüfen, ob überhautp ein Inhalt vorhanden ist.
Public Sub Daten_mehrerer_Dateien_zusammenfuehren()
'Code für ein allgemeines Modul
'Autor: Jürgen Hennekes
On Error GoTo errExit
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim varDateien As Variant
Dim lngAnzahl As Long
Dim lngLastQ As Long
Set WBZ = ActiveWorkbook
'Altdaten auf Zielblatt löschen
WBZ.Worksheets(6).Range("A2:IV65536").Clear
'Tabellenblatt umbenennen
WBZ.Worksheets(6).Name = "Meldungen Kari"
varDateien = _
Application.GetOpenFilename("Datei (*.xl*),*.xl*", False, "Bitte gewünschte Datei(en) markieren" _
_
, False, True)
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Daten aus Arbeitsblatt 6 auslesen und in Arbeitsblatt 6 einsetzen (Kari)
For lngAnzahl = LBound(varDateien) To UBound(varDateien)
Set WBQ = Workbooks.Open(Filename:=varDateien(lngAnzahl))
lngLastQ = WBQ.Worksheets(6).Range("B65536").End(xlUp).Row
WBQ.Worksheets(6).Range("B5:N" & lngLastQ).Copy _
Destination:=WBZ.Worksheets(6).Range("A" & WBZ.Worksheets(6).Range("A65536").End(xlUp).Row + _
_
1)
WBQ.Close
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "Es wurden " & UBound(varDateien) & " Dateien zusammengefügt.", 64
Exit Sub
errExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
If Err.Number = 13 Then
MsgBox "Es wurde keine Datei ausgewählt"
Else
MsgBox "Es ist ein Fehler aufgetreten!" & vbCr _
& "Fehlernummer: " & Err.Number & vbCr _
& "Fehlerbeschreibung: " & Err.Description
End If
End Sub
Ich hoffe das ist einigermaßen verständlich und freue mich auf eure Rückmeldungen.
Danke
Matze
Anzeige