AW: Makro IF-Anweisungen verschachteln
05.08.2009 19:08:21
Dirk
Hallo nochmal,
hier noch eine kleine Anpassung des Macros. Damit wird die Tabelle1 komplett befuellt, man muss dann nur noch die Summenformeln einbringen (habe jetzt leider Kinderaufsicht, da geht das nicht mehr :-)
Gruss
Dirk aus Dubai
Sub get_data2()
'Dieses Macro versorgt Tabelle Uebersicht2 mit den Daten aus den Monatstabellen
Dim SearchStr As String, lCount As Long, rFoundCell As Range, rFoundCell2 As Range, WSh As _
Worksheet
Dim N As Long, k As Long, UGruppeAddr As String, M_Uebertrag As Integer, FirstAddress As String
Dim SecondAddress As String, zz As Long, M As Long, SearchStr2 As String, UGruppeAddr2 As _
String, z As Long, LastRow As Long
Dim FirstSearch As Long, tmp As String, Regions As Integer, MyRange As String, rFoundCellNext _
As Range
Application.EnableEvents = False
'firt get rid of additional spaces
Call LeerzeichenEntfernen("Sheet1")
'On Error GoTo error
Regions = WorksheetFunction.CountIf(ThisWorkbook.Sheets("Sheet1").Columns(1), "Gebiet*")
For N = 1 To Regions
'Tabellenname festlegen
Set WSh = ThisWorkbook.Sheets("Sheet1")
'Festlegen des Suchkriterium, variable Struktur in Tabelle1
SearchStr = "Gebiet " & N
SearchStr2 = "Gebiet " & N + 1
UGruppeAddr = ""
M_Uebertrag = 1
With WSh.Columns(1)
Set rFoundCell = .Find(SearchStr, lookat:=xlWhole, LookIn:=xlValues)
If Not rFoundCell Is Nothing Then
FirstAddress = rFoundCell.Address
Sheets("Tabelle1").Cells(1 + N, 1).Value = rFoundCell
Set rFoundCellNext = .Find(SearchStr2, lookat:=xlWhole, LookIn:=xlValues)
If Not rFoundCellNext Is Nothing Then
lastaddress = rFoundCellNext.Address
Else
lastaddress = "A" & LastRow
End If
SucheNext:
'naechste Schleife bestimmt das 2te Suchkriterium (Untergruppe)
zz = 0
For M = M_Uebertrag To 4 '(3 Produktgruppen in Tabelle "Sheet1")
'suche nach unten in der Tabelle nach dem Wert aus Tabelle sheet1
SearchStr2 = "Produktart " & M 'Untergruppe
UGruppeAddr = Cells(1 + N, 1 + M).Address
If Not zz 0 Then
LastRow = ThisWorkbook.Sheets("Sheet1").Cells.Find(What:="*", After:= _
[A1], SearchDirection:=xlPrevious).Row
MyRange = Range(FirstAddress & ":" & lastaddress).Address
With WSh.Range(MyRange)
Set rFoundCell2 = .Find(SearchStr2, lookat:=xlWhole, LookIn:= _
xlValues)
retry: If Not rFoundCell2 Is Nothing Then
SecondAddress = rFoundCell2.Address
If WSh.Cells(rFoundCell2.Row, 3).Value "" Then 'check on _
Value
If WSh.Cells(rFoundCell2.Row, 1).Value = SearchStr2 _
Then
UGruppeAddr2 = Cells(rFoundCell2.Row, 3).Address
'wenn Untergruppe gefunden wurde, Wert aus Spalte 5 _
in Tabelle 'Übersicht2' uebernehmen
Sheets("Tabelle1").Cells(1, 1 + M).Value = _
SearchStr2
Sheets("Tabelle1").Range(UGruppeAddr).Value = WSh. _
Range(UGruppeAddr2).Value
Sheets("Tabelle1").Range(UGruppeAddr).Interior. _
ColorIndex = 3 + N
zz = 0
FirstSearch = 0
UGruppeAddr = ""
UGruppeAddr2 = ""
GoTo Next_M
End If
zz = zz + 1
End If
Set rFoundCell2 = .FindNext(rFoundCell2)
If Not rFoundCell2.Row > Range(lastaddress).Row Then
GoTo retry
End If
Else
'no entry was found, fill cell with remark
Sheets("Tabelle1").Cells(1, 1 + M).Value = SearchStr2
Sheets("Tabelle1").Range(UGruppeAddr).Value = "no entry"
Sheets("Tabelle1").Range(UGruppeAddr).Interior.Color = RGB( _
220, 120, 0)
FirstSearch = 0
GoTo Next_M
End If
LastRow = rFoundCell.Row + z
End With
End If
Next_M:
Next M
Else
tmp = MsgBox("Die Hauptgruppe '" & SearchStr & "' aus Tabelle Sheet1 existiert _
nicht in der Monatstabelle '" & WSh.Name & "' !" _
& vbCrLf & "Bitte überprüfen Sie die Schreibweise in Tabelle 'Sheet1'", _
vbCritical, _
"Kritischer Fehler")
If tmp = vbOK Or tmp = "" Then
Exit Sub
End If
End If
End With
Next N
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
error:
MsgBox "There was an error"
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub