Thema: Makro um eine Kleinigkeit ändern | Herbers Excel-Forum

Hallo zusammen,
ich hab da mal eine oder auch zwei Fragen. Ich habe folgendes Makro in einer Excel-Datei:

Sub HDI()
' HDI Makro
Cells.Select
Application.CutCopyMode = False
Selection.Copy
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Font
.Name = "Calibri"
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With Selection.Font
.Name = "Calibri"
.Size = 10.5
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With Selection
.VerticalAlignment = xlTop
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Cells.EntireColumn.AutoFit
Range("D12").Select
ActiveSheet.ListObjects("Tabelle_owssvr_1__1").Name = "Tabelle"
ActiveSheet.ListObjects("Tabelle").Unlist
End Sub

1. Frage: Ist es möglich, es noch irgendwie zusammen zu schrumpfen? Es dauert nämlich in der Ausführung einen Augenblick.
2. Frage: Im vorletzten Befehl steht: "Tabelle_owssvr_1__1". Mein Problem ist, dass die Tabelle auch mal Tabelle_owssvr_2 oder Tabelle_owssvr_4 o. ä. heißen kann. Wie kann ich umgehen, dass er sich am genauen Namen der Tabelle "festbeißt"?
Danke & Gruß
Sandra

Hallo Sandra,
zu. 1.
den Code schrumpfen geht kaum, außer dass man die Font-Formatierung in einem Segment machen kann.
Die Kopieraktion zu Beginn scheint mir auch überflüssig zu sein, denn du kopierts das gesamte Tabellenblatt nochmals an die gleiche Position - das frisst ggf. richtig Rechenkapazität.
Damit es schneller geht muss man soger ein bischen code hinzufügen, um die Bildschirmaktualisierung und Neuberechnung abzuschalten.
Reicht es nicht, wenn du "nur" den bereich der Liste formatierst?
zu 2.
Verwende stat des Namens die Zählnummer des Listobjekts - sollte hier 1 sein.
Nachfolgend dein Code ein wenig aufgeüeüüt und eine Variante, die nur den Listenbereich formatiert.
Die von mir zu Bemerkungen umgewandelten Zeilen

          '           .TintAndShade = 0
'          .ThemeFont = xlThemeFontMinor

(kennt mein Excel 2003 nicht) muss du wieder aktivieren.
Gruß
Franz

Sub HDI()
' HDI Makro
Dim wks As Worksheet, StatusCalc As Long
Set wks = ActiveSheet
'Makrobremsen aus
With Application
StatusCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
End With
With wks
Application.CutCopyMode = False
'    .Cells.Select
'    Selection.Copy
'    ActiveSheet.Paste
'    Application.CutCopyMode = False
With .Cells
.VerticalAlignment = xlTop
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
'           .TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
'           .TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
'           .TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
'           .TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
'           .TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
'           .TintAndShade = 0
.Weight = xlThin
End With
With .Font
.Name = "Calibri"
.Size = 10.5
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
'           .TintAndShade = 0
'          .ThemeFont = xlThemeFontMinor
End With
End With
.ListObjects(1).Name = "Tabelle"
.ListObjects("Tabelle").Unlist
.Cells.EntireColumn.AutoFit
End With
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub
Sub HDI_Variante()
' Nur der Listenbereich wird kopiert.
Dim wks As Worksheet, objListe As ListObject, StatusCalc As Long
Set wks = ActiveSheet
'Makrobremsen aus
With Application
StatusCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
End With
Set objListe = wks.ListObjects(1)
With objListe
With .Range
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.EntireColumn.AutoFit
With .Font
.Name = "Calibri"
.Size = 10.5
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
'           .TintAndShade = 0
'          .ThemeFont = xlThemeFontMinor
End With
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
'           .TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
'           .TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
'           .TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
'           .TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
'           .TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
'           .TintAndShade = 0
.Weight = xlThin
End With
End With
.Unlist
End With
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub

Hallo Franz,
die HDI-Variante läuft leider nicht. er meckert darüber:
Set objListe = wks.ListObjects(1)
With objListe
Mir fällt gerade ein, durch das "in Bereich konvertieren"
.ListObjects(1).Name = "Tabelle"
.ListObjects("Tabelle").Unlist
.Cells.EntireColumn.AutoFit
ist das kopieren und einfügen glaube ich überflüssig geworden. Leider weiß ich nicht genau, welchen Teil in dem Makro dadurch überflüssig ist.
Und vielleicht kannst Du mir bei einem anderen Problem auch helfen.
Ich exportiere vom Sharepoint daten immer wieder in ein Arbeitsblatt (nachfolgend) und das Makro soll ja quasi nur die Formatierung anpassen.
Beim Exportieren wird leider immer wieder die Spaltenüberschrift (bzw. Überschriften) mit exportiert. Kann ich das Makro dahin gehend ergänzen, dass diese Überschriften ganz zum Schluss (als letze Maßnahme des Makros) gelöscht werden (die komplette Zeile)? Leider kann ich nicht einfach sagen: Zeile 23 löschen und Zeile 25 löschen etc. da ja beim jeden Exportieren eine andere Anzahl von Datensätzen exportiert wird.
Ich hoffe Du verstehst was ich meine.
Natürlich darf die erste Zeile mit den Spaltenüberschriften nicht gelöscht werden.
Noch einmal kurz zu Frage zwei:
Die Daten die ich aus dem Sharepoint exportiere werden als Tabelle in Excel eingefügt und heißen dann z. B. Tabelle_owssvr_4__1 oder Tabelle_owssvr_2 etc. Damit er diese Tabellen (egal welche) "in Bereich konvertiert" habe ich den "Befehle" geben wollen, das der Tabellenname immer Tabelle ist und das "Tabelle" immer "in Bereich konvertiert" wird. Ich glaube das hat was mit dem Tabellennamen zu tun dass HDI Variante nicht läuft.
Vielen vielen vielen Dank für Deine Hilfe.
Gruß
Sandra
P. s. So sehen die beiden Makros bei mir aus:

Sub HDI()
' HDI Makro
Dim wks As Worksheet, StatusCalc As Long
Set wks = ActiveSheet
'Makrobremsen aus
With Application
StatusCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
End With
With wks
Application.CutCopyMode = False
.Cells.Select
Selection.Copy
ActiveSheet.Paste
Application.CutCopyMode = False
With .Cells
.VerticalAlignment = xlTop
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Font
.Name = "Calibri"
.Size = 10.5
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
End With
.ListObjects(1).Name = "Tabelle"
.ListObjects("Tabelle").Unlist
.Cells.EntireColumn.AutoFit
End With
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub

Sub HDI_Variante()
' Nur der Listenbereich wird kopiert.
Dim wks As Worksheet, objListe As ListObject, StatusCalc As Long
Set wks = ActiveSheet
'Makrobremsen aus
With Application
StatusCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
End With
Set objListe = wks.ListObjects(1)
With objListe
With .Range
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.EntireColumn.AutoFit
With .Font
.Name = "Calibri"
.Size = 10.5
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
.Unlist
End With
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub

Hallo Sandra,
ich hab nochmals ein wenig gebastelt.
Das Makro soll das Listobject mit der Zählnummer 1 in einen Bereich umwandeln, da spielt dann der Name der Tabelle (des Listobjekts) keine Rolle. Wenn in dem Tabellenblatt kein Listobjekt mehr ist, dann kommt es zu dem Fehler. Ich hab jetzt eine kleine Fehlerprüfroutine eingebaut, so dass das Makro ggf. ordnungsgemäß beendet wird.
Zum Problem mit der Titelzeile der vom Sharepoint eingefügten Tabelle(Listobjekt).
Das Makro merkt sich vor der Umwandling der Tabelle in einen Bereich die 1. Zeile der Tabelle und löscht diese nach der Umwandlung. Hoffe das passt so.
Code als hochgeladene Text-Datei:
https://www.herber.de/bbs/user/65789.txt
Die Zeilen, die du nach Meiner Meinung rausschmeißen kannst hab ich markiert.
Gruß
Franz

Hallo Franz,
ersteinmal ganz ganz lieben Dank für Deine Hilfe. Das Kopieren und einfügen an einer STelle habe ich gemacht, weil ich die eingefügten Datensätze (tabellen) nicht formatieren konnte. Rahmen, Schriftart etc. hat er nicht angenommen. Ich bin erst hinterher darauf gestoßen, dass es funktioniert, wenn ich die Tabelle "in Bereich konvertiere".
Nun muss das Makro aber trotzdem noch einmal ändern.
Im Moment sieht es "nur noch" so aus (Ich habe mich für HDI_Variante statt für HDI entschieden - geht bedeutend schneller :-)):

Sub HDI_Variante()
' Spalten des Listenbereichs werden formatiert und Tabelle(Listobjekt) in _
in einen Bereich umgewandelt.
Dim wks As Worksheet, objListe As ListObject, StatusCalc As Long
Dim ZeileTitel As Long
Set wks = ActiveSheet
'Makrobremsen aus
With Application
StatusCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
End With
Set objListe = wks.ListObjects(1)
With objListe
With .Range.EntireColumn
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.AutoFit
With .Font
.Name = "Calibri"
.Size = 10.5
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
'Titelzeile der Tabelle(Listobjekt merken)
ZeileTitel = .Range.Row
'Tabelle in Bereich umwandeln
.Unlist
End With
'Zeile mit Titelzeilen des früheren Listobjekts löschen
wks.Rows(ZeileTitel).Delete shift:=xlShiftUp
ResumeFehler:
Fehler:
With Err
Select Case .Number
Case 0 'kein Fehler
Case 9 'Index-Fehler Objekt nicht gefunden
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
& "Im Blatt gibt es wohl keine Tabelle (Listobject) mehr!"
Resume ResumeFehler:
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf _
& "intFehler = " & intFehler
End Select
End With
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub

Nun ist mir aufgefallen oder eher eingefallen, dass nicht immer das ganze Blatt neu formatiert werden muss. Es muss immer nur der neu eingefügte Bereich formatiert werden. Dieser ist ja immer markiert. Kannst Du mir dabei auch noch einmal helfen?
Was aber an HDI_Variante im Vergleich zu HDI anders ist - er verbreitert die Spalten so, dass der Text nicht mehr mit Zeilenumbruch dargestellt wird. Das ist Schlecht, weil manchmal gaaaaanz viel Text in einer einzelnen Zelle steht.
Woran liegt das?
Vielen lieben & herzlichen Dank!!!!!!!
Liebste Grüße
Sandra

Hallo Franz,
eine Sache ist noch anders bei HDI_Variante - es sollten alle Zellen linksbündig ausgericht werden. Leider funktioniert das nicht. Teilweise werden die Daten rechtsbündig dargestellt.
Kannst Du mir auch da noch einmal helfen?
Besten Dank!
Gruß
Sandra

Hi
grade wenn du Formate änderst, zeichnet Excel idR mehr auf, als in vielen Fällen notwendig ist.
wenn zu z.B. einen Rahmen zeichnen willst, ohne ihm eine spezielle Farbe zu geben, dann reicht folgender Code aus, die nicht angegeben Parameter bleiben erhalten oder bekommen den Standardwert:
anstelle von:

With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

reicht oft ein:

Selection.Borders(xlEdgeLeft).Weight=xlThin

völlig aus.
Ebenso beim Schriftformat, auch hier reicht es oft aus, nur das Format anzugeben, das auch geändert werden soll:

Selection.Font.Name = "Calibri"

um nochmal auf den Rahmen zurückzukommen:
falls ein Zellbereich auf allen Seiten die gleiche Rahmenart bekommen soll, kann man auch die .BORDERAROUND-Methode verwenden:

Selection.BorderAround Weight:=xlThin, Linestyle:=xlContinuous

Außerdem solltest du nicht mit Select arbeiten, sondern immer die Zellbereiche direkt angeben, dh nicht:
Range("A1:A2").Select
Selection.Font.Colorindex = 3
schreiben, sonden:
Range("A1:A2").Font.Colorindex = 3
Gruß, Daniel

Okay. Ich guck mal was ich da machen kann. Ich muss das Makro aber noch mal ändern.
Im Moment sieht es "nur noch" so aus:

Sub HDI_Variante()
' Spalten des Listenbereichs werden formatiert und Tabelle(Listobjekt) in _
in einen Bereich umgewandelt.
Dim wks As Worksheet, objListe As ListObject, StatusCalc As Long
Dim ZeileTitel As Long
Set wks = ActiveSheet
'Makrobremsen aus
With Application
StatusCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
End With
Set objListe = wks.ListObjects(1)
With objListe
With .Range.EntireColumn
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.AutoFit
With .Font
.Name = "Calibri"
.Size = 10.5
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
'Titelzeile der Tabelle(Listobjekt merken)
ZeileTitel = .Range.Row
'Tabelle in Bereich umwandeln
.Unlist
End With
'Zeile mit Titelzeilen des früheren Listobjekts löschen
wks.Rows(ZeileTitel).Delete shift:=xlShiftUp
ResumeFehler:
Fehler:
With Err
Select Case .Number
Case 0 'kein Fehler
Case 9 'Index-Fehler Objekt nicht gefunden
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
& "Im Blatt gibt es wohl keine Tabelle (Listobject) mehr!"
Resume ResumeFehler:
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf _
& "intFehler = " & intFehler
End Select
End With
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub

Nun ist mir aufgefallen oder eher eingefallen, dass nicht immer das ganze Blatt neu formatiert werden muss. Es muss immer nur der neu eingefügte Bereich formatiert werden. Dieser ist ja immer markiert. Könnt Ihr mir dabei auch noch einmal helfen? Das wäre total klasse von Euch!
Vielen lieben & herzlichen Dank!!!!!!!
Liebste Grüße
Sandra

Hallo Sandra,
nimm in meiner Variante die Zeile

      .WrapText = False

ganz raus oder setze den Wert auf True. Dann sollten die Spaltenbreiten erhalten bleiben und der Text entsprechend umgebrochen werden.
Ansonsten kann man natürlich auch das Autofit der Spaltenbreiten weglassen, denn die Spaltenbreiten sollten sich doch eigentlich nicht mehr ändern, sobald die 1. Tabelle eingefügt ist.
Gruß
Franz

Klappt super - danke!
Hast Du für das Andere auch noch eine Lösung parat?
Was würde ich nur ohne Euch machen?
Ganz liebe Grüße!!!!

Hallo Sandra,
hatte ich übersehen,
wenn du nur den eingfügten Bereich mit der Liste aufbereiten willst und nicht die kompletten Spalten, dann entferne hier das ".EntireColumn".

  Set objListe = wks.ListObjects(1)
With objListe
With .Range.EntireColumn
.HorizontalAlignment = xlGeneral

Gruß
Franz

Jetzt funktioniert FAST alles bestens!!!!
Habe die Linksausrichtung slebst noch hinbekommen.
Leider kommen die Chefs immer mit Änderungswünschen - Problemen, wenn man glaubt, dass man fertig ist.
Zur Erklärung:
Ich exportiere vom Sharepoint ein Batagebuch (Stand heute z. B. 3 Datensätze). Dann werden noch zwei dazu erfasst und morgen exportiere ich dann 5 Datensätze. Allerdings sind die ersten Beiden doppelt, da ich diese ja schon einmal exportiert habe.
Kann das Makro so ergänzt/ umgeschrieben werden, dass es doppelte Zeilen (nicht einzelne Zelle) automatisch löscht? Es muss der Inhalt in den Zeilen von Spalten A - F übereinstimmen, damit es gelöscht werden darf. Nur eine Übereinstimmung oder zwei reichen nicht.
Gibt es sowas wie: Wenn in zwei (oder mehr) Zeilen der Inhalt in den Spalten A - F 100% identish ist,k dann darf bzw. muss die gerade importierte, doppelte Zelle gelöscht werden.
Mein Makro sieht jetzt so aus:

Sub HDI_Variante()
' Spalten des Listenbereichs werden formatiert und Tabelle(Listobjekt) in _
in einen Bereich umgewandelt.
Dim wks As Worksheet, objListe As ListObject, StatusCalc As Long
Dim ZeileTitel As Long
Set wks = ActiveSheet
'Makrobremsen aus
With Application
StatusCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
End With
Set objListe = wks.ListObjects(1)
With objListe
With .Range
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With .Font
.Name = "Calibri"
.Size = 10.5
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
'Titelzeile der Tabelle(Listobjekt merken)
ZeileTitel = .Range.Row
'Tabelle in Bereich umwandeln
.Unlist
End With
'Zeile mit Titelzeilen des früheren Listobjekts löschen
wks.Rows(ZeileTitel).Delete shift:=xlShiftUp
ResumeFehler:
Fehler:
With Err
Select Case .Number
Case 0 'kein Fehler
Case 9 'Index-Fehler Objekt nicht gefunden
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
& "Im Blatt gibt es wohl keine Tabelle (Listobject) mehr!"
Resume ResumeFehler:
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf _
& "intFehler = " & intFehler
End Select
End With
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub

Ich bedanke mich schon jetzt für Eure Mühe!!!!!

Hallo Sandra,
und der nächste Baustein ist auch drin.
Ich hab eine benutzerdefinierte Funktion eingebaut, die doppelte Zeilen in einem Bereich unter Nutzung des Spezialfilters sucht. Die gefundenen Zeilen werden dann gelöscht.
Gruß
Franz
Hier die angepassten Prozeduren als Textdatei
https://www.herber.de/bbs/user/65844.txt

Guten Morgen Franz,
sag mal, was machst Du denn nachts, wenn andere Leute schlafen?
Das Ergebnis ... - RESPEKT!!!
Also funktionieren tut es ja, ABER (dieses kleine BÖSE Wort)....
kann man den Vorgang auch beschleunigen? Jetzt ist die Ausführung nämlich wieder gaaaaaaaanz langsam.
Und eine (hoffentlich endgültige) Ergänzung benötige ich noch...
Der Druckbereich soll automatisch so erweitert werden, dass er nach einfügen der Daten und löschen der doppelten Datensätze auf die letzte "beschriebene" Zeile erweitert wird.
DANKE und einen gaaaaanz dicken und Lieben Gruß an Dich!
Sandra

Hallo Sandra,
möglicherweise gibt es im Code ein Problem, wenn die letzte benutzte Zeile ermittelt wird, wiel irgendwo weit unten in der Datei noch eine Zelle benutzt wird (besondere Formatierung reicht schon.
Ich hab jetzt dafür eine separate Function eingebaut.
Die Druckbereichsanpassung ist auch drin.
Bei ca. 500 Zeilen in der Liste dauert die Aktualisierung der Daten weniger als 2 Sekunden.
Gruß
Franz
Textdatei mit Code:
https://www.herber.de/bbs/user/65859.txt

DU BIST EIN SCHATZ!!!!!!!!!!!!!!!
DAAAAAAAAAAAAAAAAAAAAAAAAAAANKE!!!!!!!!!!!
Läuft Super!!!!!!