AW: Zeile durchsuchen und Spalte dann kopieren
12.01.2018 11:10:37
UweD
Hallo nochmal
hab das für Datum / Date eingebaut.
Option Explicit
Private Sub Workbook_Open()
Dim TB1, TB2, LR1 As Double, LR2 As Double, LC As Integer, EZ1 As Integer, EZ2 As Integer
Dim ArrBegr, ArrWo, Z As Integer, Spalte As Integer, SpTmp As Integer
Set TB1 = Sheets("Rohdaten")
Set TB2 = Sheets("Vorlage")
EZ1 = 4 'Zeile in der gesucht wird
EZ2 = 5 'Zielzeile für Daten
ArrBegr = Array("Datum", "Stufe", "Typ") 'die Suchbegriffe für Rohdaten
ArrWo = Array(1, 2, 4) 'die Einfügespalten für die Suchbegriffe
With WorksheetFunction
LR1 = .Max(EZ1, TB1.Cells.SpecialCells(xlCellTypeLastCell).Row) 'letze Spalte des gesamten Blattes
LR2 = .Max(EZ2, TB2.Cells.SpecialCells(xlCellTypeLastCell).Row)
'Reset ohne Überschriften
TB2.Rows(EZ2).Resize(LR2 - EZ2 + 1).ClearContents
If LR1 > EZ1 Then 'sind Werte vorhanden?
For Z = Lbound(ArrBegr, 1) To Ubound(ArrBegr, 1)
If .CountIf(TB1.Rows(EZ1), ArrBegr(Z)) > 0 Then 'Ist Suchbegriff in Zeile EZ1 =4 vorhanden?
Spalte = .Match(ArrBegr(Z), TB1.Rows(EZ1), 0) 'in welcher Spalte steht der Begriff
'Datum / Date normieren
If ArrBegr(Z) = "Datum" Then
If .CountIf(TB1.Rows(EZ1), "Date") > 0 Then
SpTmp = .Match("Date", TB1.Rows(EZ1), 0)
With TB1
LC = .Cells.SpecialCells(xlCellTypeLastCell).Column + 1 'nächste freie Spalte des gesamten Blattes
'Hilfsspalte mit Formel; Wenn kein Datum dann nimm Date
.Range(.Cells(EZ1 + 1, LC), .Cells(LR1, LC)).FormulaR1C1 = _
"=IF(RC" & Spalte & "="""",RC" & SpTmp & ",RC" & Spalte & ")"
Spalte = LC
MsgBox "Datum / Date vereint"
End With
Else
MsgBox "Spalte 'Date' wurde nicht gefunden"
End If
End If
'Übertragen ohne Überschrift
TB2.Cells(EZ2, ArrWo(Z)).Resize(LR1 - EZ1 + 1).Value = _
TB1.Cells(EZ1 + 1, Spalte).Resize(LR1 - EZ1 + 1).Value
'Temoräre DatumSpalte löschen
If LC > 0 Then TB1.Columns(LC).ClearContents
Else
'Fehlermeldung, wenn der Suchbegriff in Rohdaten nicht gefunden wird
MsgBox "Suchbegriff '" & ArrBegr(Z) & "' wurde nicht gefunden"
End If
Next
'Fertig
MsgBox "Rohdaten übernommen!"
Else
'Keine Daten unter Zeile EZ1 =4 vorhanden
MsgBox "Keine Rohdaten vorhanden!"
End If
End With
End Sub
LG UweD