Makro zu lang

Forumthread: Makro zu lang

Makro zu lang

15.03.2021 18:37:37

oraculix

Hallo
Ich habe ein Macro das Fehlerfrei Funktioniert, doch leider ist es ziemlich lang.
Kann mir jemand helfen das Macro zu verkürtzen?
Option Explicit
'Csv Datei aus EMDB in FILMDB automatisch Aktualisieren

Public Sub ImportCSV()
Application.ScreenUpdating = False
Sheets("FilmDB").Activate
Dim objFileDialog As FileDialog
Dim objWorkbook As Workbook
Dim strFilePath As String
Set objFileDialog = Application.FileDialog(fileDialogType:=msoFileDialogOpen)
With objFileDialog
.AllowMultiSelect = False
.FilterIndex = 6
.InitialFileName = "F:\!Software\OFFICE 2019\alle filme3.csv" ' Anpassen !!!
.Title = "Importdatei auswählen"
If .Show Then strFilePath = .SelectedItems(1)
End With
Set objFileDialog = Nothing
If strFilePath  vbNullString Then
Set objWorkbook = Workbooks.Open(Filename:=strFilePath)
Call objWorkbook.Worksheets(1).Columns("A:J").Copy(Destination:=ThisWorkbook. _
ActiveSheet.Cells(1, 1))
Call objWorkbook.Close(SaveChanges:=False)
Set objWorkbook = Nothing
End If
'Nur 1 Zeile Formatieren Formatieren
With ThisWorkbook.Worksheets("FilmDB").Activate ''''

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Makro zu lang

15.03.2021 18:40:48

oraculix
AW: Makro zu lang

15.03.2021 19:21:09

Nepumuk
AW: Makro zu lang

15.03.2021 19:32:20

oraculix
AW: Makro zu lang

15.03.2021 19:36:59

Daniel
AW: Makro zu lang

15.03.2021 21:36:42

oraculix

AW: Makro zu lang

15.03.2021 18:40:48

oraculix

teil 2 des Makros sorry hat er nicht genommen vieleicht weil es zu lang ist.
Range("A1:J5000").Interior.Color = vbBlack
Range("A1:J5000").Font.Color = RGB(255, 192, 0)
Range("A1:J5000").Borders.Color = RGB(255, 192, 0)
Range("A1:J5000").Font.Size = 14
End With
'Schrift Ausrichtung von A-J
Columns("A:B").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("C:C").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("D:D").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
Columns("E:E").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("F:F").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("G:I").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1:I1").Select
Range("I1").Activate
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Application.Goto Reference:=Worksheets("FilmDB").Range("A1"), _
Scroll:=True
'Liest aus Verzeichniss E:\ Alle Filme aus und gibt sie als Link aus
Sheets("FilmeAnsehen").Activate
Const FILE_PATH As String = "E:\"
Dim lngRow As Long
Dim strFilename As String
Application.ScreenUpdating = False
lngRow = 1
Call Range(Cells(3, 1), Cells(Rows.Count, 1)).ClearContents
strFilename = Dir$(FILE_PATH & "*.*")
Do Until strFilename = vbNullString
lngRow = lngRow + 1
Call ActiveSheet.Hyperlinks.Add(Anchor:=Cells(lngRow, 1), _
Address:=FILE_PATH & strFilename, _
TextToDisplay:=Left$(strFilename, InStrRev(strFilename, ".") - 1))
strFilename = Dir$
Loop
Columns(1).Font.Size = 15
'''''''''''
With ThisWorkbook.Worksheets("FilmeAnsehen").Activate
Range("A2:C300").Interior.Color = vbBlack
Range("A2:C300").Font.Color = RGB(255, 192, 0)
Range("A2:C300").Borders.Color = RGB(255, 192, 0)
' LÖSCHEN VON ÜBERFLÜSSIGEN DATEN SPALTEN ANPASSEN
Columns("B:J").Select
Selection.ClearContents
Columns("A:A").ColumnWidth = 64.28
Range("A1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.799981688894314
End With
Selection.Font.Size = 16
Selection.Font.Size = 18
Range("B1:C1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With
Application.ScreenUpdating = True
Application.ScreenUpdating = True
End Sub

AW: Makro zu lang

15.03.2021 19:21:09

Nepumuk

Hallo,
teste mal:

Option Explicit

Public Sub ImportCSV()

    Const FILE_PATH As String = "E:\"
    Dim lngRow As Long
    Dim strFilename As String
    Dim objFileDialog As FileDialog
    Dim objWorkbook As Workbook
    Dim strFilePath As String

    Application.ScreenUpdating = False

    Worksheets("FilmDB").Activate

    Set objFileDialog = Application.FileDialog(fileDialogType:=msoFileDialogOpen)

    With objFileDialog

        .AllowMultiSelect = False
        .FilterIndex = 6
        .InitialFileName = "F:\!Software\OFFICE 2019\alle filme3.csv" ' Anpassen !!!
        .Title = "Importdatei auswählen"

        If .Show Then strFilePath = .SelectedItems(1)

    End With

    Set objFileDialog = Nothing

    If strFilePath <> vbNullString Then

        Set objWorkbook = Workbooks.Open(Filename:=strFilePath)

        Call objWorkbook.Worksheets(1).Columns("A:J").Copy(Destination:=ThisWorkbook. _
            ActiveSheet.Cells(1, 1))

        Call objWorkbook.Close(SaveChanges:=False)

        Set objWorkbook = Nothing

    End If

    With Range("A1:J5000")
        .Interior.Color = vbBlack
        .Font.Color = RGB(255, 192, 0)
        .Borders.Color = RGB(255, 192, 0)
        .Font.Size = 14
    End With

    'Schrift Ausrichtung von A-J
    Columns("A:B").HorizontalAlignment = xlLeft
    Columns("C:C").HorizontalAlignment = xlCenter
    Columns("D:E").HorizontalAlignment = xlLeft
    Columns("F:I").HorizontalAlignment = xlCenter
    Range("A1:I1").HorizontalAlignment = xlCenter
    Range("A1").Select

    'Liest aus Verzeichniss E:\ Alle Filme aus und gibt sie als Link aus
    Worksheets("FilmeAnsehen").Activate

    lngRow = 1

    Call Range(Cells(3, 1), Cells(Rows.Count, 1)).ClearContents

    strFilename = Dir$(FILE_PATH & "*.*")

    Do Until strFilename = vbNullString

        lngRow = lngRow + 1

        Call ActiveSheet.Hyperlinks.Add(Anchor:=Cells(lngRow, 1), _
            Address:=FILE_PATH & strFilename, _
            TextToDisplay:=Left$(strFilename, InStrRev(strFilename, ".") - 1))

        strFilename = Dir$

    Loop

    Columns(1).Font.Size = 15

    With Range("A2:C300")
        .Interior.Color = vbBlack
        .Font.Color = RGB(255, 192, 0)
        .Borders.Color = RGB(255, 192, 0)
    End With

    ' LÖSCHEN VON ÜBERFLÜSSIGEN DATEN SPALTEN ANPASSEN
    Columns("B:J").ClearContents
    Columns("A:A").ColumnWidth = 64.28

    With Range("A1")
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent2
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        With .Font
            .ThemeColor = xlThemeColorAccent4
            .TintAndShade = 0.799981688894314
            .Size = 18
        End With
    End With

    With Range("B1:C1").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

    Application.ScreenUpdating = True

End Sub

Gruß
Nepumuk

AW: Makro zu lang

15.03.2021 19:32:20

oraculix

Genial wie immer . Unglaublich wie du das alles erkennst.
Vielen Dank kein einziger Fehler .

AW: Makro zu lang

15.03.2021 19:36:59

Daniel

Hi
Mit dem Recorder aufgezeichneter Code sollte immer überarbeitet werden:
1. Scrollen im Bildschirm löschen:
ActiveWindow.ScrollColumn/-Tow
2. Select/Selection weglassen und den Befehl direkt an den Zellbereich anhägen.
Dafür hast due genügend beispiele im Code, WO due dir days anschauen kannst.
3. Der Recorder zeichnet brim Formatieren von Zellen mehr Eigenschaften auf, als man geändert hat.
Oft kann man viele von diesen löschen und nur die behalten, die man ändern will.
Bei dir dürfte das für den ersten Block das HorizontalAlignment sein, den Rest der Formatierungszeilen kannst du löschen
4. ggf Zellbereiche auch nicht zusammenhängende Zellbereiche gemeinsam formatieren
5. nicht benötige Schritte oder solche die wieder überschrieben werden, löschen
Dh das "Schrift ausrichten A-J" fasst sich zusammen zu

Range("A:B,D:E").HorizontalAlignment = xlLeft
Range("C:C,F:I").HorizontalAlignment = xlCenter
Range("A1:I1").HorizontalAlignment = xlCenter

Gruß Daniel

AW: Makro zu lang

15.03.2021 21:36:42

oraculix

Danke hab jetzt einiges dazugelernt !!!!

Beliebteste Forumthreads (12 Monate)

Forumthread: Makro zu lang

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread