Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Makro um eine Kleinigkeit ändern | Herbers Excel-Forum


Betrifft: Makro um eine Kleinigkeit ändern von: Sandra
Geschrieben am: 11.11.2009 15:01:29

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

  

Betrifft: AW: Makro um eine Kleinigkeit ändern von: fcs
Geschrieben am: 11.11.2009 16:49:18

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



  

Betrifft: AW: Makro um eine Kleinigkeit ändern von: Sandra
Geschrieben am: 11.11.2009 17:18:31

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



  

Betrifft: AW: Makro um eine Kleinigkeit ändern von: fcs
Geschrieben am: 12.11.2009 00:08:00

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


  

Betrifft: AW: Makro um eine Kleinigkeit ändern von: Sandra
Geschrieben am: 12.11.2009 08:14:05

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


  

Betrifft: AW: Makro um eine Kleinigkeit ändern von: Sandra
Geschrieben am: 12.11.2009 08:17:23

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


  

Betrifft: AW: Makro kürzen von: Daniel
Geschrieben am: 12.11.2009 03:00:05

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


  

Betrifft: AW: Makro kürzen von: Sandra
Geschrieben am: 12.11.2009 08:09:13

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


  

Betrifft: AW: Makro um eine Kleinigkeit ändern von: Sandra
Geschrieben am: 12.11.2009 08:24:53




  

Betrifft: AW: Makro um eine Kleinigkeit ändern von: fcs
Geschrieben am: 12.11.2009 12:32:57

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


  

Betrifft: AW: Makro um eine Kleinigkeit ändern von: Sandra
Geschrieben am: 12.11.2009 14:44:50

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!!!!


  

Betrifft: AW: Makro um eine Kleinigkeit ändern von: fcs
Geschrieben am: 12.11.2009 17:17:50

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


  

Betrifft: AW: Makro um eine Kleinigkeit ändern von: Sandra
Geschrieben am: 12.11.2009 18:11:31

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!!!!!


  

Betrifft: AW: Excel 2007 - Function Löschen Doppelte Zeilen von: fcs
Geschrieben am: 13.11.2009 01:56:28

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


  

Betrifft: AW: Excel 2007 - Function Löschen Doppelte Zeilen von: Sandra
Geschrieben am: 13.11.2009 09:03:40

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


  

Betrifft: AW: Excel 2007 - Function Löschen Doppelte Zeilen von: fcs
Geschrieben am: 13.11.2009 11:30:35

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


  

Betrifft: AW: Excel 2007 - Function Löschen Doppelte Zeilen von: Sandra
Geschrieben am: 13.11.2009 12:17:39

DU BIST EIN SCHATZ!!!!!!!!!!!!!!!


DAAAAAAAAAAAAAAAAAAAAAAAAAAANKE!!!!!!!!!!!

Läuft Super!!!!!!


Beiträge aus den Excel-Beispielen zum Thema "Makro um eine Kleinigkeit ändern"