leider habe ich noch ein Problem,
dies beschäftigt mich schon den ganzen tag. Einige Sachen konnte ich mit eurer Hilfe schon einbauen. Nur ich komme schon wieder nicht weiter.
Ich möchte gern eine Tabelle formatieren. Das untenstehende macro funktioniert schon am besten von all meinen versuchen. Nur leider bekomme ich keinen dicken Rahmen und keine dünnen Rahmen hin und die Überschrift will auch nicht klappen. Da ich dies schwer erklären kann habe ich eine testdatei erstellt. In dieser befinden sich eigentlich meine versuche und ein Wunschergebnis.
Mit dem Versuch Macro formatieren3 geht es auch bestimmt irgentwie hier ist das problem ich bekomme zwar gezielt die Zeile angesprochen aber dann formatiere ich wieder die gesamte zeile. anstatt nur von Spalte b bis m .
hat noch jemand Lust dies sich mal anzuschauen? ich schaffe es einfach nicht.
liebe grüsse thomas
https://www.herber.de/bbs/user/101048.xlsm
Sub formatieren_ausgang()
Dim lngUeberschriftRow As Long, lngLastRow As Long, lngFirstRow As Long
Dim lngSpesenCol As Long, lngNameCol As Long, lngI As Long, letztezeile As Long
Dim strQuellueberschrift As String, strSpesen As String, strTabelle As String
On Error GoTo ErrExit
strQuellueberschrift = "Name"
strSpesen = "Rechnung"
strTabelle = "Tabelle1"
With Sheets(strTabelle)
lngUeberschriftRow = .Cells.Find(strQuellueberschrift, LookAt:=xlWhole).Row
lngNameCol = .Rows(lngUeberschriftRow).Find(strQuellueberschrift, LookAt:=xlWhole).Column
lngSpesenCol = .Rows(lngUeberschriftRow).Find(strSpesen, LookAt:=xlWhole).Column
lngFirstRow = .Cells(lngUeberschriftRow, lngNameCol).Row
letztezeile = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
lngLastRow = Sheets(strTabelle).Cells(Rows.Count, lngNameCol).End(xlUp).Row
Sheets(strTabelle).Cells(lngUeberschriftRow, lngNameCol).Select ' Spalte Namen markieren
Selection.CurrentRegion.Select ' Bereich markieren
If Selection.Columns.Count > 1 Then
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
' Formatieren
For lngI = lngUeberschriftRow To lngLastRow
.Range(Sheets(strTabelle).Cells(lngI, lngNameCol), Sheets(strTabelle).Cells(lngI, _
lngSpesenCol)).Font.Bold = .Cells(lngI, lngNameCol).Value Like "*Gesamtergebnis*"
.Range(Sheets(strTabelle).Cells(lngI, lngNameCol), Sheets(strTabelle).Cells(lngI, _
lngSpesenCol)).Font.Bold = .Cells(lngI, lngNameCol).Value Like "*Name*"
.Range(Sheets(strTabelle).Cells(lngI, lngNameCol), Sheets(strTabelle).Cells(lngI, _
lngSpesenCol)).Font.Bold = .Cells(lngI, lngNameCol).Value Like "*Ergebnis*"
.Range(Sheets(strTabelle).Cells(lngI, lngNameCol), Sheets(strTabelle).Cells(lngI, _
lngSpesenCol)).Interior.ColorIndex = IIf(Sheets(strTabelle).Cells(lngI, lngNameCol).Value Like "*Ergebnis*", 34, xlColorIndexNone)
.Range(Sheets(strTabelle).Cells(lngI, lngNameCol), Sheets(strTabelle).Cells(lngI, _
lngSpesenCol)).BorderAround ColorIndex:=IIf(Sheets(strTabelle).Cells(lngI, lngNameCol).Value Like "*Ergebnis*", 1, xlThick = 4)
Next
' Rahmen um Zellen zeichnen
ErrExit:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "Fehler Spalten_uhrzeiten_formatieren'" & vbLf & _
String(60, "_") & vbLf & vbLf & _
IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & "Fehlernummer:" & vbTab & _
_
.Number & vbLf & vbLf & "Beschreibung:" & vbTab & .Description & vbLf, vbExclamation + _
_
vbMsgBoxSetForeground, "VBA - Fehler in Prozedur - daten"
.Clear
End If
End With
End With
On Error GoTo 0
Application.ScreenUpdating = True
End Sub