AW: Leere Zellen suchen mit Macro
12.08.2004 10:03:27
Alexander
Hallo Kdosi,
so jetzt hab ich das ganze mal ausprobiert und noch etwas erweitert und angepasst:
Ich habe jetzt zwei Mappen (Name Mappe1) hier stehen die Daten drin die überprüft werden sollen. In der zweiten Mappe (Name TestDatei_2) befinden sich die Macros.
Ich bin so vorgegangen:
Zuerst wird das Worksheet, in das die Daten kopiert werden sollen leer gemacht und die Überschriften aus der Datendatei kopiert. Dann wird eine Hilfsspalte (A) in das Daten Sheet der ersten Mappe angelegt mit den 7 etc. Dies alles macht ein Macro.
Als nächstes wird Dein Code ausgeführt mit einem weiteren Macro.
Im Prinzip läuft auch alles ohne Fehler.
Allerdings hab ich noch zwei Probleme bei denen ich leider noch etwas Unterstützung benötige:
1. Ist es auch möglich das Kriterium (die 7) statt mit einer Zahl auch mit einem Text zu verwenden? Dann wäre die Bedingungen wenn leere Zellen und in V steht PPPhase kopiere die Zeile. Das hat bei mir nicht geklappt.
2. Spalte V Spalte W
PPPhase 7654
PPPhase 7890
PPPhase
PPSubStage 5671
In der Spalte W ist immer der letzte Eintrag leer. Das ist auch OK. Also hier wäre die Bedingung Spalte V ist PPPhase und leer erfüllt. Aber das ist in diesem Fall richtig und zwar immer dann wenn in der darauf folgenden Zeile V nicht mehr PPPhase steht sondern ein anderer Wert. Z.B. PPSubStage. Diese Zeile soll dann nicht mit kopiert werden
Ich würde mich freuen wenn Du mir hierbei noch helfen könntest ich weiß leider nicht weiter.
Gruß und Danke Alexander
Na toll jetzt kann ich nicht uploaden also hier der Code:
Problem 2 ist 'Für Sucessors aus Spalte X
Public Sub Main_Test1()
'On Error GoTo Err_In_Main_Test
Dim spalte, tabelle, kriterium, spalte1, tabelle1, kriterium1, spalte2, tabelle2, kriterium2
'Für Sucessors aus Spalte X
Set spalte2 = Workbooks("Mappe1.xls").Worksheets("Process").Columns("X")
Set tabelle2 = Workbooks("TestDatei_2.xls").Worksheets("Export")
kriterium2 = 7
'Für gewährtem Zeittyp aus Spalte V
Set spalte1 = Workbooks("Mappe1.xls").Worksheets("Process").Columns("V")
Set tabelle1 = Workbooks("TestDatei_2.xls").Worksheets("Export")
kriterium1 = 7
'Für Workcenter aus Spalte F
Set spalte = Workbooks("Mappe1.xls").Worksheets("Process").Columns("F")
Set tabelle = Workbooks("TestDatei_2.xls").Worksheets("Export")
kriterium = 7
' man ruft die Function FindEmptyCellsWithCriterion
Dim LeerenZellen, LeerenZellen1, LeerenZellen2
' Workcenter
LeerenZellen = FindEmptyCellsWithCriterion(spalte, tabelle, kriterium)
' Gewährtem Zeittyp
LeerenZellen1 = FindEmptyCellsWithCriterion(spalte1, tabelle1, kriterium1)
'Sucessors
LeerenZellen2 = FindEmptyCellsWithCriterion(spalte2, tabelle2, kriterium2)
'If (VBA.IsNull(LeerenZellen) = False) Then
' VBA.MsgBox "Die Tabelle wo man gesucht hat : " & spalte.Parent.Name & VBA.vbCrLf & _
' "Die Ziel-Tabelle : " & tabelle.Name & VBA.vbCrLf & _
' "Die Spalte wo man gesucht hat : " & spalte.Column & VBA.vbCrLf & _
' "Das Kriterium : " & VBA.CStr(kriterium) & VBA.vbCrLf & VBA.vbCrLf & _
' "Die Anzahl der kopierten Zeilen : " & LeerenZellen, vbInformation
'Else
' VBA.MsgBox "Der Ergebniss ist NULL.", vbExclamation
'End If
'Exit Sub
' ---------------------------------------------------------
'Err_In_Main_Test:
' VBA.MsgBox Err.Description, vbCritical, "Error Number " & Err.Number
Workbooks("TestDatei_2.xls").Worksheets("Export").Activate
End Sub
' FindEmptyCellsWithCriterion returns die Anzahl den leeren Zellen,
' oder NULL, wenn die Parametern NOTHING sind
Private Function FindEmptyCellsWithCriterion(ByVal i_rngColumn As Range, _
ByVal i_wshExport As Worksheet, _
ByVal i_vntKriterium As Variant) As Variant
' required
If (i_rngColumn Is Nothing Or i_wshExport Is Nothing) Then
FindEmptyCellsWithCriterion = Null
Exit Function
End If
On Error GoTo Err_In_FindEmptyCellsWithCriterion
FindEmptyCellsWithCriterion = 0
Dim rngCell As Range, rngColumnUsed As Range
Set rngColumnUsed = Application.Intersect(i_rngColumn.Columns(1), i_rngColumn.Parent.UsedRange)
If (rngColumnUsed Is Nothing) Then Exit Function
For Each rngCell In rngColumnUsed.Cells
If (IsEmpty(rngCell) = True And _
VBA.CStr(rngCell.Offset(0, -rngCell.Column + 1).Value) = VBA.CStr(i_vntKriterium)) Then
rngCell.EntireRow.Copy i_wshExport.Range("a" & _
i_wshExport.UsedRange.Rows(i_wshExport.UsedRange.Rows.Count).Row + 1)
FindEmptyCellsWithCriterion = FindEmptyCellsWithCriterion + 1
End If
Next rngCell
Exit Function
Err_In_FindEmptyCellsWithCriterion:
VBA.MsgBox Err.Description, vbCritical
FindEmptyCellsWithCriterion = Null
End Function
' IsEmpty Function overrides VBA.IsEmpty
' IsEmpty returns True, wenn alle Zellen im i_rng Bereich leer sind
' sonnst returns False, NULL wenn i_rng Is NOTHING
Private Function IsEmpty(ByVal i_rng As Range) As Variant
' required
If (i_rng Is Nothing) Then
IsEmpty = Null
Exit Function
End If
Dim rngCell As Range
IsEmpty = True
For Each rngCell In i_rng.Cells
If (rngCell.Value <> "") Then
IsEmpty = False
Exit Function
End If
Next rngCell
End Function