VBA Code vereinfachen / kürzen / optimieren

  • Excel

Es gibt 9 Antworten in diesem Thema. Der letzte Beitrag () ist von petaod.

    VBA Code vereinfachen / kürzen / optimieren

    Hallo zusammen,

    in einem Excel Workbook wird beim Start das erste Tabellenblatt mit Sharepoint synchronisiert. Dabei werden viele unnötige leere Absätze in die Zellen geschrieben. Diese Absätze sind aber sehr unpraktisch weil die Tabelleneinträge später von Word (Seriendruckfunktion) übernommen werden....

    Ich hab dieses löschen der Leer-Absätze mittels VBA gelöst, allerdings reichen meine Programmierkenntnisse nicht aus, das in einer Loopschleife o.ä. zu verpacken.

    Ich erbitte hiermit also eure Hilfe den ganzen Code etwas eleganter zu gestalten:


    Quellcode

    1. ​Private Sub Workbook_Open()
    3. 'Daten aktualisieren
    4. ActiveWorkbook.RefreshAll
    6. 'Aus Spalten unnötige Absätze löschen
    7. Dim arr, tmp As String, sp As Integer, k As Integer, i As Long
    8. sp = 1
    9. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    10. arr = Split(Cells(i, sp).Value, vbLf)
    11. For k = LBound(arr) To UBound(arr)
    12. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    13. Next k
    14. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    15. tmp = ""
    16. Next i
    18. sp = 2
    19. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    20. arr = Split(Cells(i, sp).Value, vbLf)
    21. For k = LBound(arr) To UBound(arr)
    22. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    23. Next k
    24. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    25. tmp = ""
    26. Next i
    28. sp = 3
    29. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    30. arr = Split(Cells(i, sp).Value, vbLf)
    31. For k = LBound(arr) To UBound(arr)
    32. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    33. Next k
    34. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    35. tmp = ""
    36. Next i
    38. sp = 4
    39. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    40. arr = Split(Cells(i, sp).Value, vbLf)
    41. For k = LBound(arr) To UBound(arr)
    42. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    43. Next k
    44. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    45. tmp = ""
    46. Next i
    48. sp = 5
    49. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    50. arr = Split(Cells(i, sp).Value, vbLf)
    51. For k = LBound(arr) To UBound(arr)
    52. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    53. Next k
    54. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    55. tmp = ""
    56. Next i
    58. sp = 6
    59. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    60. arr = Split(Cells(i, sp).Value, vbLf)
    61. For k = LBound(arr) To UBound(arr)
    62. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    63. Next k
    64. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    65. tmp = ""
    66. Next i
    68. sp = 7
    69. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    70. arr = Split(Cells(i, sp).Value, vbLf)
    71. For k = LBound(arr) To UBound(arr)
    72. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    73. Next k
    74. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    75. tmp = ""
    76. Next i
    78. sp = 8
    79. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    80. arr = Split(Cells(i, sp).Value, vbLf)
    81. For k = LBound(arr) To UBound(arr)
    82. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    83. Next k
    84. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    85. tmp = ""
    86. Next i
    88. sp = 9
    89. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    90. arr = Split(Cells(i, sp).Value, vbLf)
    91. For k = LBound(arr) To UBound(arr)
    92. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    93. Next k
    94. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    95. tmp = ""
    96. Next i
    98. sp = 10
    99. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    100. arr = Split(Cells(i, sp).Value, vbLf)
    101. For k = LBound(arr) To UBound(arr)
    102. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    103. Next k
    104. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    105. tmp = ""
    106. Next i
    108. sp = 11
    109. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    110. arr = Split(Cells(i, sp).Value, vbLf)
    111. For k = LBound(arr) To UBound(arr)
    112. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    113. Next k
    114. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    115. tmp = ""
    116. Next i
    118. sp = 12
    119. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    120. arr = Split(Cells(i, sp).Value, vbLf)
    121. For k = LBound(arr) To UBound(arr)
    122. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    123. Next k
    124. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    125. tmp = ""
    126. Next i
    128. sp = 13
    129. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    130. arr = Split(Cells(i, sp).Value, vbLf)
    131. For k = LBound(arr) To UBound(arr)
    132. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    133. Next k
    134. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    135. tmp = ""
    136. Next i
    138. End Sub

    Visual Basic-Quellcode

    1. Private Sub Workbook_Open()
    3. 'Daten aktualisieren
    4. ActiveWorkbook.RefreshAll
    6. 'Aus Spalten unnötige Absätze löschen
    7. Dim arr, tmp As String, sp As Integer, k As Integer, i As Long
    9. For sp = 1 To 13
    10. For i = 1 To Cells(Rows.Count, sp).End(xlUp).Row
    11. arr = Split(Cells(i, sp).Value, vbLf)
    12. For k = LBound(arr) To UBound(arr)
    13. If Trim(arr(k)) <> "" Then tmp = tmp & arr(k) & vbLf
    14. Next k
    15. If tmp <> "" Then Cells(i, sp) = Left(tmp, Len(tmp) - 1)
    16. tmp = ""
    17. Next i
    18. Next sp
    19. End Sub

    ungetestet

    Du führst den selben Block immer wieder (13x) aus und incrementierst deine sp-Variable.
    Also kannst du das auch in eine For schleife bauen und sparst dir dadurch - naja - eben 12 mal den Block :D


    LG Acr0most
    Wenn das Leben wirklich nur aus Nullen und Einsen besteht, dann laufen sicherlich genügen Nullen frei herum. :D
    Signature-Move 8o
    kein Problem mit privaten Konversationen zu Thema XY :thumbup:

    Ich arbeite an einer neuen Exceldatei und habe dort nun ziemlich viel Code mittels Makrorekorder usw. erstellt.
    Nun ist die Geschichte an einem Punkt angekommen an der es träge wird. Eventuell hat ja einer die Muse da drüber zuschauen und mir den ein oder anderen Verbesserungsvorschlag zu geben....hier der Code:


    Quellcode

    1. ​Option Explicit
    3. Sub Datenimport_Insgesamt()
    5. Dim ImportDatei As Variant
    6. Dim wbImport As Workbook
    7. Dim LetzteZeile2 As Long
    8. Dim Zeilenanzahl As Integer
    9. Dim Spaltenanzahl As Integer
    10. Dim wks As Worksheet
    11. Dim wks2 As Worksheet
    12. Dim zeile As Long
    18. Application.ScreenUpdating = False
    20. 'Öffnet MsgBox "Datei öffnen"
    21. ImportDatei = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.xlsx; *.xlsm; *.xls; *.xlsb),*.xlsx; *.xlsm; *.xls; *.xlsb", Title:="Eine Datei auswählen")
    23. If ImportDatei = False Then
    24. MsgBox "Der Benutzer hat abgebrochen.", vbInformation
    26. Else
    28. 'Kopiert die Inhalte aus geöffneter Exceldatei und fügt Sie in Auswertung.xlsm ein
    29. Set wbImport = Workbooks.Open(ImportDatei)
    31. With ActiveSheet
    32. .Range("A2", .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Copy
    33. End With
    34. ThisWorkbook.Worksheets("Import").Cells(4, 1).PasteSpecial Paste:=xlPasteValues
    35. Application.CutCopyMode = False
    37. wbImport.Close savechanges:=False
    38. Set wbImport = Nothing
    40. 'ThisWorkbook.Worksheets("Import").Activate
    42. ActiveWorkbook.Worksheets("Import").AutoFilter.Sort.SortFields.Clear
    43. ActiveWorkbook.Worksheets("Import").AutoFilter.Sort.SortFields.Add Key:=Range _
    44. ("H4:H65536"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    45. xlSortNormal
    46. With ActiveWorkbook.Worksheets("Import").AutoFilter.Sort
    47. .Header = xlYes
    48. .MatchCase = False
    49. .Orientation = xlTopToBottom
    50. .SortMethod = xlPinYin
    51. .Apply
    52. End With
    54. 'Fehlende Änderungsdatum Angabe ersetzen durch "Angelegt am" Datum
    56. LetzteZeile2 = Range("H65535").End(xlUp).Offset(1, 0).Row
    57. Cells(LetzteZeile2, "H").Select
    58. ActiveCell.FormulaR1C1 = "=RC[1]"
    59. Cells(LetzteZeile2, "H").AutoFill Destination:=Range(Cells(LetzteZeile2, "H"), Cells(10000, "H"))
    61. 'Aktuelles Datum in CE1
    62. Range("CE1").Select
    63. ActiveCell.FormulaR1C1 = "=TODAY()"
    65. 'Hinter allen Verwendeten Zeilen Datum
    66. Range("J4").Select
    67. ActiveCell.FormulaR1C1 = "=IF(ISNONTEXT(RC[-6]),"""",(R1C[73]))"
    68. Range("J4").Select
    69. Selection.AutoFill Destination:=Range("J4:J10000")
    70. Range("J4:J10000").Select
    72. 'Hinter allen Datumsableitung einfügen
    74. Range("L4").Select
    75. ActiveCell.FormulaR1C1 = "=YEAR(RC[-4])"
    76. ' ActiveCell.FormulaR1C1 = "=IF(ISNONTEXT(RC[-6]),"""",(R1C[73]))"
    77. Range("L4").Select
    78. Selection.AutoFill Destination:=Range("L4:L10000")
    79. Range("L4:L10000").Select
    81. 'Kopiert den benutzten Bereich im Tabellenblatt "Import" und fügt alles auf Tabellenblatt "Import ohne Dublikate" ein
    82. Zeilenanzahl = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    83. Spaltenanzahl = ActiveSheet.Cells(Zeilenanzahl, Columns.Count).End(xlToLeft).Column
    84. Range(Cells(4, 1), Cells(Zeilenanzahl, Spaltenanzahl)).Copy
    86. Sheets("Import ohne Dublikate").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, _
    87. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    89. 'Setzt Filter
    90. ActiveSheet.UsedRange.AutoFilter Field:=6, Criteria1:=Array( _
    91. "MAFR INIT", "MAFR INIT ANGE", "MAFR INIT ANGE ERL", "MAFR INIT ANGE WDER", _
    92. "MAFR INIT ERL", "MAFR INIT ERL WDER", "MAFR INIT ERL WDSP", "MAFR INIT WDSP", _
    93. "MAFR MAH2", "MAFR MAH2 ERL", "MAOF INIT", "MAOF INIT ANGE ERL"), Operator:= _
    94. xlFilterValues
    96. 'Benutzten, gefilterten Bereich kopieren und auf "nur offene Maßnahmen" und "Offen Ohne Dublikate" einfügen
    97. Zeilenanzahl = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    98. Spaltenanzahl = ActiveSheet.Cells(Zeilenanzahl, Columns.Count).End(xlToLeft).Column
    100. Range(Cells(4, 1), Cells(Zeilenanzahl, Spaltenanzahl)).Copy
    101. Sheets("nur offene Maßnahmen").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, _
    102. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    104. 'Dublikate löschen
    105. Sheets("nur offene Maßnahmen").Select
    106. Columns("A:J").Select
    107. ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(2, 3, 4, 9), _
    108. Header:=xlYes
    110. Range(Cells(2, 1), Cells(Zeilenanzahl, Spaltenanzahl)).Copy
    111. Sheets("Offen Ohne Dublikate").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, _
    112. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    114. 'Filter zurücksetzen auf Tabellenblatt "Import"
    115. ThisWorkbook.Worksheets("Import").Activate
    116. ActiveSheet.UsedRange.AutoFilter Field:=6
    118. End If
    120. 'Dublikate aus Tabellenblatt "Offen Ohne Dublikate" löschen
    121. ThisWorkbook.Worksheets("Offen Ohne Dublikate").Activate
    122. Set wks = ThisWorkbook.Worksheets("Offen Ohne Dublikate")
    123. ActiveSheet.UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
    125. Sheets("Offen Ohne Dublikate").Select
    126. Columns("A:J").Select
    127. ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(2, 3, 4, 9), _
    128. Header:=xlYes
    130. 'Dublikate aus Tabellenblatt "Import ohne Dublikate" löschen
    131. ThisWorkbook.Worksheets("Import ohne Dublikate").Activate
    132. Set wks2 = ThisWorkbook.Worksheets("Import ohne Dublikate")
    133. ActiveSheet.UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
    135. 'SAP Datenstand archivieren auf Tabellenblatt "Archiv"
    136. ThisWorkbook.Worksheets("Import").Activate
    137. Zeilenanzahl = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    138. Spaltenanzahl = ActiveSheet.Cells(Zeilenanzahl, Columns.Count).End(xlToLeft).Column
    140. Range(Cells(4, 1), Cells(Zeilenanzahl, Spaltenanzahl)).Copy
    141. Sheets("Archiv").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, _
    142. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    144. Sheets("Archiv").Select
    145. Columns("A:J").Select
    146. ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(2, 3, 4, 9), _
    147. Header:=xlYes
    149. 'Inhalte in Tabellenblatt Import löschen
    150. Worksheets("Import").Cells.Clear
    152. Sheets("Import").Select
    153. 'Leere Zeilen von unten nach oben löschen
    154. With Tabelle1
    155. '.UsedRange ist der verwendete Bereich der Tabelle
    156. 'Schleife beim Löschen immer von unten nach oben durchlaufen lassen !
    157. For zeile = .UsedRange.Row + .UsedRange.Rows.Count - 1 To 1 Step -1
    158. 'Application.CountA entspricht der Funktion =ANZAHL2()
    159. 'und zählt, wieviele gefüllte Zellen der Bereich (hier : die Zeile) enthält
    160. If Application.CountA(.Rows(zeile)) = 0 Then .Rows(zeile).EntireRow.Delete
    161. Next
    162. End With
    164. Sheets("Import ohne Dublikate").Select
    165. 'Leere Zeilen von unten nach oben löschen
    166. With Tabelle6
    167. '.UsedRange ist der verwendete Bereich der Tabelle
    168. 'Schleife beim Löschen immer von unten nach oben durchlaufen lassen !
    169. For zeile = .UsedRange.Row + .UsedRange.Rows.Count - 1 To 1 Step -1
    170. 'Application.CountA entspricht der Funktion =ANZAHL2()
    171. 'und zählt, wieviele gefüllte Zellen der Bereich (hier : die Zeile) enthält
    172. If Application.CountA(.Rows(zeile)) = 0 Then .Rows(zeile).EntireRow.Delete
    173. Next
    174. End With
    176. Sheets("nur offene Maßnahmen").Select
    177. 'Leere Zeilen von unten nach oben löschen
    178. With Tabelle5
    179. '.UsedRange ist der verwendete Bereich der Tabelle
    180. 'Schleife beim Löschen immer von unten nach oben durchlaufen lassen !
    181. For zeile = .UsedRange.Row + .UsedRange.Rows.Count - 1 To 1 Step -1
    182. 'Application.CountA entspricht der Funktion =ANZAHL2()
    183. 'und zählt, wieviele gefüllte Zellen der Bereich (hier : die Zeile) enthält
    184. If Application.CountA(.Rows(zeile)) = 0 Then .Rows(zeile).EntireRow.Delete
    185. Next
    186. End With
    188. Sheets("Offen Ohne Dublikate").Select
    189. 'Leere Zeilen von unten nach oben löschen
    190. With Tabelle2
    191. '.UsedRange ist der verwendete Bereich der Tabelle
    192. 'Schleife beim Löschen immer von unten nach oben durchlaufen lassen !
    193. For zeile = .UsedRange.Row + .UsedRange.Rows.Count - 1 To 1 Step -1
    194. 'Application.CountA entspricht der Funktion =ANZAHL2()
    195. 'und zählt, wieviele gefüllte Zellen der Bereich (hier : die Zeile) enthält
    196. If Application.CountA(.Rows(zeile)) = 0 Then .Rows(zeile).EntireRow.Delete
    197. Next
    198. End With
    200. Sheets("Archiv").Select
    201. 'Leere Zeilen von unten nach oben löschen
    202. With Tabelle3
    203. '.UsedRange ist der verwendete Bereich der Tabelle
    204. 'Schleife beim Löschen immer von unten nach oben durchlaufen lassen !
    205. For zeile = .UsedRange.Row + .UsedRange.Rows.Count - 1 To 1 Step -1
    206. 'Application.CountA entspricht der Funktion =ANZAHL2()
    207. 'und zählt, wieviele gefüllte Zellen der Bereich (hier : die Zeile) enthält
    208. If Application.CountA(.Rows(zeile)) = 0 Then .Rows(zeile).EntireRow.Delete
    209. Next
    210. End With
    212. Sheets("Import ohne Dublikate").Select
    213. Columns("H:H").Select
    214. Selection.NumberFormat = "m/d/yyyy"
    216. Sheets("nur offene Maßnahmen").Select
    217. Columns("H:H").Select
    218. Selection.NumberFormat = "m/d/yyyy"
    220. Sheets("Offen Ohne Dublikate").Select
    221. Columns("H:H").Select
    222. Selection.NumberFormat = "m/d/yyyy"
    224. Sheets("Archiv").Select
    225. Columns("H:H").Select
    226. Selection.NumberFormat = "m/d/yyyy"
    229. Sheets("nur offene Maßnahmen").Range("A1:J1").Copy
    230. Sheets("Import").Select
    231. Range("A3").Select
    232. ActiveSheet.Paste
    233. Application.CutCopyMode = False
    234. Selection.AutoFilter
    236. Application.ScreenUpdating = True
    238. Sheets("Pivot Tabelle").Select
    240. End Sub

    Man sieht schon sehr deutlich, dass das aufgezeichneter Code ist.
    ersetze erst mal im ganzen Code die Select-Statements und Selection-Objekte durch Direktadressierung.

    FrankyWill schrieb:

    Sheets("Archiv").Select
    Columns("H:H").Select
    Selection.NumberFormat = "m/d/yyyy"

    Visual Basic-Quellcode

    1. Sheets("Archiv").Columns("H:H").NumberFormat = "m/d/yyyy"
    Vielleicht wird's dann schon mal übersichtlicher, dass man sich überhaupt an Optimierung ran trauen kann.

    Auch Konstrukte mit Activate solltest du vermeiden :

    FrankyWill schrieb:

    ThisWorkbook.Worksheets("Import").Activate
    ActiveSheet.UsedRange.AutoFilter Field:=6

    Visual Basic-Quellcode

    1. ThisWorkbook.Worksheets("Import").UsedRange.AutoFilter Field:=6
    Oder besser noch, verwende hier die Objektnamen des Sheets

    Visual Basic-Quellcode

    1. Tabelle5.UsedRange.AutoFilter Field:=6
    Und wenn du in der IDE der Tabelle5 noch einen vernünftigen Name wie z.B. Import gibst:

    Visual Basic-Quellcode

    1. Import.UsedRange.AutoFilter Field:=6
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Hier mal mein überarbeiteter Code. @petaod: Wie genau meinst du dass mit den Tabellen Namen geben?

    Alleine das Aufräumen der ganzen select Geschichten hat tatsächlich unfassbare Performance freigesetzt! Ich würde jetzt nur gerne noch
    die leeren Zeilen unterhalb meiner Tabellen löschen. Jemand einen Tipp? Meine Lösung steht unterhalb des eigentlichen Codes...Danke!!!

    Quellcode

    1. ​Option Explicit
    3. Sub Datenimport_Insgesamt()
    5. Dim ImportDatei As Variant
    6. Dim wbImport As Workbook
    7. Dim LetzteZeile2 As Long
    8. Dim Zeilenanzahl As Integer
    9. Dim Spaltenanzahl As Integer
    10. Dim wks As Worksheet
    11. Dim wks2 As Worksheet
    12. Dim zeile As Long
    13. Dim lngSpalte As Long
    14. Dim a As Long
    17. Application.ScreenUpdating = False
    19. 'Öffnet MsgBox "Datei öffnen"
    20. ImportDatei = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.xlsx; *.xlsm; *.xls; *.xlsb),*.xlsx; *.xlsm; *.xls; *.xlsb", Title:="Eine Datei auswählen")
    22. If ImportDatei = False Then
    23. MsgBox "Der Benutzer hat abgebrochen.", vbInformation
    25. Else
    27. 'Kopiert die Inhalte aus geöffneter Exceldatei und fügt Sie in Auswertung.xlsm ein
    28. Set wbImport = Workbooks.Open(ImportDatei)
    30. With ActiveSheet
    31. .Range("A2", .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Copy
    32. End With
    33. ThisWorkbook.Worksheets("Import").Cells(2, 1).PasteSpecial Paste:=xlPasteValues
    34. Application.CutCopyMode = False
    36. wbImport.Close savechanges:=False
    37. Set wbImport = Nothing
    39. ActiveWorkbook.Worksheets("Import").AutoFilter.Sort.SortFields.Clear
    40. ActiveWorkbook.Worksheets("Import").AutoFilter.Sort.SortFields.Add Key:=Range _
    41. ("H2:H65536"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    42. xlSortNormal
    44. With ActiveWorkbook.Worksheets("Import").AutoFilter.Sort
    45. .Header = xlYes
    46. .MatchCase = False
    47. .Orientation = xlTopToBottom
    48. .SortMethod = xlPinYin
    49. .Apply
    50. End With
    53. 'Fehlende Änderungsdatum Angabe ersetzen durch "Angelegt am" Datum
    54. LetzteZeile2 = Range("H65535").End(xlUp).Offset(1, 0).Row
    55. Cells(LetzteZeile2, "H").FormulaR1C1 = "=RC[1]"
    56. Cells(LetzteZeile2, "H").AutoFill Destination:=Range(Cells(LetzteZeile2, "H"), Cells(10000, "H"))
    58. 'Aktuelles Datum in CE1
    59. Range("CE1").FormulaR1C1 = "=TODAY()"
    61. 'Hinter allen Verwendeten Zeilen Datum
    62. Range("J2").FormulaR1C1 = "=IF(ISNONTEXT(RC[-6]),"""",(R1C[73]))"
    63. Range("J2").AutoFill Destination:=Range("J2:J10000")
    65. 'Hinter allen Datumsableitung einfügen
    66. Range("L2").FormulaR1C1 = "=YEAR(RC[-4])"
    67. Range("L2").AutoFill Destination:=Range("L2:L10000")
    69. 'Kopiert den benutzten Bereich im Tabellenblatt "Import" und fügt alles auf Tabellenblatt "Import ohne Dublikate" ein
    70. Zeilenanzahl = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    71. Spaltenanzahl = ActiveSheet.Cells(Zeilenanzahl, Columns.Count).End(xlToLeft).Column
    72. Range(Cells(2, 1), Cells(Zeilenanzahl, Spaltenanzahl)).Copy
    74. Sheets("Import ohne Dublikate").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, _
    75. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    77. 'Setzt Filter
    78. Sheets("Import").UsedRange.AutoFilter Field:=6, Criteria1:=Array( _
    79. "MAFR INIT", "MAFR INIT ANGE", "MAFR INIT ANGE ERL", "MAFR INIT ANGE WDER", _
    80. "MAFR INIT ERL", "MAFR INIT ERL WDER", "MAFR INIT ERL WDSP", "MAFR INIT WDSP", _
    81. "MAFR MAH2", "MAFR MAH2 ERL", "MAOF INIT", "MAOF INIT ANGE ERL"), Operator:= _
    82. xlFilterValues
    84. 'Benutzten, gefilterten Bereich kopieren und auf "nur offene Maßnahmen" und "Offen Ohne Dublikate" einfügen
    85. Zeilenanzahl = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    86. Spaltenanzahl = ActiveSheet.Cells(Zeilenanzahl, Columns.Count).End(xlToLeft).Column
    88. Range(Cells(2, 1), Cells(Zeilenanzahl, Spaltenanzahl)).Copy
    89. Sheets("nur offene Maßnahmen").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, _
    90. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    92. 'Dublikate löschen
    93. Sheets("nur offene Maßnahmen").UsedRange.RemoveDuplicates Columns:=Array(2, 3, 4, 9), _
    94. Header:=xlYes
    96. Range(Cells(2, 1), Cells(Zeilenanzahl, Spaltenanzahl)).Copy
    97. Sheets("Offen Ohne Dublikate").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, _
    98. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    100. 'Filter zurücksetzen auf Tabellenblatt "Import"
    101. Sheets("Import").UsedRange.AutoFilter Field:=6
    103. End If
    105. 'Dublikate aus Tabellenblatt "Offen Ohne Dublikate" löschen
    106. Sheets("Offen Ohne Dublikate").UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
    107. Sheets("Offen Ohne Dublikate").UsedRange.RemoveDuplicates Columns:=Array(2, 3, 4, 9), _
    108. Header:=xlYes
    110. 'Dublikate aus Tabellenblatt "Import ohne Dublikate" löschen
    111. Sheets("Import ohne Dublikate").UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
    113. 'SAP Datenstand archivieren auf Tabellenblatt "Archiv"
    114. ThisWorkbook.Worksheets("Import").Activate
    115. Zeilenanzahl = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    116. Spaltenanzahl = ActiveSheet.Cells(Zeilenanzahl, Columns.Count).End(xlToLeft).Column
    118. Range(Cells(2, 1), Cells(Zeilenanzahl, Spaltenanzahl)).Copy
    119. Sheets("Archiv").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, _
    120. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    122. Sheets("Archiv").UsedRange.RemoveDuplicates Columns:=Array(2, 3, 4, 9), _
    123. Header:=xlYes
    125. 'Inhalte in Tabellenblatt Import löschen
    126. Worksheets("Import").Range("A2:L10000").Select
    127. Selection.Clear
    130. Sheets("Import ohne Dublikate").Columns("H:H").NumberFormat = "m/d/yyyy"
    132. Sheets("nur offene Maßnahmen").Columns("H:H").NumberFormat = "m/d/yyyy"
    134. Sheets("Offen Ohne Dublikate").Columns("H:H").NumberFormat = "m/d/yyyy"
    136. Sheets("Archiv").Columns("H:H").NumberFormat = "m/d/yyyy"
    140. Application.ScreenUpdating = True
    142. Sheets("Pivot Tabelle").Select
    144. End Sub



    Quellcode

    1. ​ Sheets("Import").Select
    2. '** Spalte, die auf Leerzeichen geprüft werden soll
    3. lngSpalte = 1
    5. For a = ActiveSheet.Cells(Rows.Count, lngSpalte).End(xlUp).Row To 1 Step -1
    6. If ActiveSheet.Cells(a, 1).Value = "" Then
    7. Rows(a).Delete shift:=xlUp
    8. End If
    10. Next a
    12. Sheets("Import ohne Dublikate").Select
    13. '** Spalte, die auf Leerzeichen geprüft werden soll
    14. lngSpalte = 1
    16. For a = ActiveSheet.Cells(Rows.Count, lngSpalte).End(xlUp).Row To 1 Step -1
    17. If ActiveSheet.Cells(a, 1).Value = "" Then
    18. Rows(a).Delete shift:=xlUp
    19. End If
    21. Next a
    23. Sheets("nur offene Maßnahmen").Select
    24. '** Spalte, die auf Leerzeichen geprüft werden soll
    25. lngSpalte = 1
    27. For a = ActiveSheet.Cells(Rows.Count, lngSpalte).End(xlUp).Row To 1 Step -1
    28. If ActiveSheet.Cells(a, 1).Value = "" Then
    29. Rows(a).Delete shift:=xlUp
    30. End If
    32. Next a
    34. Sheets("Offen Ohne Dublikate").Select
    35. '** Spalte, die auf Leerzeichen geprüft werden soll
    36. lngSpalte = 1
    38. For a = ActiveSheet.Cells(Rows.Count, lngSpalte).End(xlUp).Row To 1 Step -1
    39. If ActiveSheet.Cells(a, 1).Value = "" Then
    40. Rows(a).Delete shift:=xlUp
    41. End If
    43. Next a
    45. Sheets("Archiv").Select
    46. '** Spalte, die auf Leerzeichen geprüft werden soll
    47. lngSpalte = 1
    49. For a = ActiveSheet.Cells(Rows.Count, lngSpalte).End(xlUp).Row To 1 Step -1
    50. If ActiveSheet.Cells(a, 1).Value = "" Then
    51. Rows(a).Delete shift:=xlUp
    52. End If
    54. Next a

    FrankyWill schrieb:

    Wie genau meinst du dass mit den Tabellen Namen geben?
    Im VBA-Editor klickst du links das Worksheet an.
    Dann siehst du unten im Eigenschaftsfenster die Properties des Sheets.
    Falls das Fenster nicht da ist, F4 drücken.
    Jetzt kannst du in der Spalte (Name) den Objektnamen überschreiben.
    z.B. Import statt Tabelle1.
    Dann kannst du zukünftig das Sheet anstatt mit SheetNamen Sheets("Import") mittels Objektnamen Import adressieren.

    Fangen wir mal mit dem ersten Abschnitt an.

    FrankyWill schrieb:

    Set wbImport = Workbooks.Open(ImportDatei)
    With ActiveSheet
    .Range("A2", .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Copy
    End With
    ThisWorkbook.Worksheets("Import").Cells(2, 1).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    wbImport.Close savechanges:=False
    Set wbImport = Nothing

    Würde ich so schreiben

    Visual Basic-Quellcode

    1. Set wbImport = Workbooks.Open(ImportDatei)
    2. Set CopySheet = wbImport.Sheets(1)
    3. Set CopyRange = Intersect(CopySheet.UsedRange, CopySheet.Range("2:" & Rows.Count))
    4. Import.Range(CopyRange.Address).Value = CopyRange.Value
    5. wbImport.Close Savechanges:=False
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Ui, das macht die ganze Sache ja um längen Eleganter. Auch diesesmal vielen Dank dafür! Ich werde das mal umsetzen...


    Hab die Objektnamen nun geändert, was tatsächlich einiges vereinfacht. Insbesondere für folgende VBA Projekte eine super Sache. Ich habe aber ein anderes, etwas seltsames Problem und ich finde die Ursache nicht....Im Grundegenommen importiere ich aus einer SAP erzeugten Exceldatei gewisse Daten, die dann in meiner Datei gefiltert, sortiert, gelöscht und auf verschiedene Tabellenblätter kopiert werden. Wenn ich mit F8 den Code Schrittweise durchlaufe, habe ich am Ende mein gewünschtes Ergebnis auf den verschiedenen Tabellenblätter.Lass ich den Code aber im ganzen, vollständig und ohne Einzelschritte durchlaufen habe ich plötzlich auf zwei Tabellenblättern den selben Inhalt. Auf IoD und OOD sind die selben Daten, um die 305 Einträge dabei sollte auf OOD jedoch nur 96 sein...was läuft da schief?


    Quellcode

    1. Option Explicit
    3. Sub Datenimport_Insgesamt()
    5. Dim wbImport As Workbook
    6. Dim ws As Worksheet
    7. Dim wks As Worksheet
    8. Dim wks2 As Worksheet
    9. Dim p As PivotTable
    11. Dim ImportDatei As String
    12. Dim CopySheet As String
    13. Dim CopyRange As String
    15. Dim LetzteZeile2 As Long
    16. Dim Zeilenanzahl As Long
    17. Dim Zeilenanzahl2 As Long
    18. Dim Zeilenanzahl3 As Long
    19. Dim Spaltenanzahl As Long
    20. Dim Spaltenanzahl2 As Long
    21. Dim Spaltenanzahl3 As Long
    22. Dim zeile As Long
    23. Dim lngSpalte As Long
    24. Dim a As Long
    27. Application.ScreenUpdating = False
    29. Import.Select
    31. 'Öffnet MsgBox "Datei öffnen"
    32. ImportDatei = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.xlsx; *.xlsm; *.xls; *.xlsb),*.xlsx; *.xlsm; *.xls; *.xlsb", Title:="Eine Datei auswählen")
    34. If ImportDatei = False Then
    35. MsgBox "Der Benutzer hat abgebrochen.", vbInformation
    37. Else
    39. Set wbImport = Workbooks.Open(ImportDatei)
    40. Set CopySheet = wbImport.Sheets(1)
    41. Set CopyRange = Intersect(CopySheet.UsedRange, CopySheet.Range("2:" & Rows.Count))
    42. Import.Range(CopyRange.Address).Value = CopyRange.Value
    43. wbImport.Close Savechanges:=False
    45. Import.AutoFilter.Sort.SortFields.Clear
    46. Import.AutoFilter.Sort.SortFields.Add Key:=Range("H2:H65536"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    48. With Import.AutoFilter.Sort
    49. .Header = xlYes
    50. .MatchCase = False
    51. .Orientation = xlTopToBottom
    52. .SortMethod = xlPinYin
    53. .Apply
    54. End With
    55. End If
    57. 'Fehlende Änderungsdatum Angabe ersetzen durch "Angelegt am" Datum
    58. LetzteZeile2 = Range("H65535").End(xlUp).Offset(1, 0).Row
    59. Cells(LetzteZeile2, "H").FormulaR1C1 = "=RC[1]"
    60. Cells(LetzteZeile2, "H").AutoFill Destination:=Range(Cells(LetzteZeile2, "H"), Cells(10000, "H"))
    62. 'Aktuelles Datum in CE1
    63. Range("CE1").FormulaR1C1 = "=TODAY()"
    65. 'Hinter allen Verwendeten Zeilen Datum
    66. Range("J2").FormulaR1C1 = "=IF(ISNONTEXT(RC[-6]),"""",(R1C[73]))"
    67. Range("J2").AutoFill Destination:=Range("J2:J10000")
    69. 'Hinter allen Datumsableitung einfügen
    70. Range("L2").FormulaR1C1 = "=YEAR(RC[-4])"
    71. Range("L2").AutoFill Destination:=Range("L2:L10000")
    73. 'Markiert und Kopiert den benutzten Bereich im Tabellenblatt "Import"
    74. Zeilenanzahl = Import.Cells(Rows.Count, 1).End(xlUp).Row
    75. Spaltenanzahl = Import.Cells(Zeilenanzahl, Columns.Count).End(xlToLeft).Column
    76. Range(Cells(2, 1), Cells(Zeilenanzahl, Spaltenanzahl)).Copy
    78. 'Fügt alles auf Tabellenblatt "Import ohne Dublikate" ein
    79. IoD.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, _
    80. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    82. 'Dublikate aus Tabellenblatt "Import ohne Dublikate" löschen
    83. IoD.UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
    85. 'Setzt Filter
    86. Import.UsedRange.AutoFilter Field:=6, Criteria1:=Array( _
    87. "MAFR INIT", "MAFR INIT ANGE", "MAFR INIT ANGE ERL", "MAFR INIT ANGE WDER", _
    88. "MAFR INIT ERL", "MAFR INIT ERL WDER", "MAFR INIT ERL WDSP", "MAFR INIT WDSP", _
    89. "MAFR MAH2", "MAFR MAH2 ERL", "MAOF INIT", "MAOF INIT ANGE ERL"), Operator:=xlFilterValues
    91. 'Benutzten, gefilterten Bereich auf "Import" kopieren
    92. Zeilenanzahl2 = Import.Cells(Rows.Count, 1).End(xlUp).Row
    93. Spaltenanzahl2 = Import.Cells(Zeilenanzahl2, Columns.Count).End(xlToLeft).Column
    94. Range(Cells(2, 1), Cells(Zeilenanzahl2, Spaltenanzahl2)).Copy
    96. 'Fügt alles auf Tabellenblatt "nur offene Maßnahmen" ein
    97. noM.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    99. 'Dublikate löschen auf "nur offene Maßnahmen"
    101. Range(Cells(2, 1), Cells(Zeilenanzahl2, Spaltenanzahl2)).Copy
    103. OOD.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    105. 'Dublikate aus Tabellenblatt "Offen Ohne Dublikate" löschen
    106. OOD.UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
    107. OOD.UsedRange.RemoveDuplicates Columns:=Array(2, 3, 4, 9), Header:=xlYes
    109. 'Filter zurücksetzen auf Tabellenblatt "Import"
    110. Import.UsedRange.AutoFilter Field:=6
    112. 'SAP Datenstand archivieren auf Tabellenblatt "Archiv"
    113. Zeilenanzahl3 = Import.Cells(Rows.Count, 1).End(xlUp).Row
    114. Spaltenanzahl3 = Import.Cells(Zeilenanzahl3, Columns.Count).End(xlToLeft).Column
    115. Range(Cells(2, 1), Cells(Zeilenanzahl3, Spaltenanzahl3)).Copy
    117. Archiv.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    119. Archiv.UsedRange.RemoveDuplicates Columns:=Array(2, 3, 4, 10), Header:=xlYes
    121. 'Inhalte in Tabellenblatt Import löschen
    122. Import.Select
    123. Import.Range("A2:L10000").Select
    124. Selection.Clear
    127. IoD.Columns("H:H").NumberFormat = "m/d/yyyy"
    129. noM.Columns("H:H").NumberFormat = "m/d/yyyy"
    131. OOD.Columns("H:H").NumberFormat = "m/d/yyyy"
    133. Archiv.Columns("H:H").NumberFormat = "m/d/yyyy"
    135. 'Pivot Tabellen aktualisieren
    136. For Each ws In ActiveWorkbook.Worksheets
    137. For Each p In ws.PivotTables
    138. p.RefreshTable
    139. Next
    140. Next
    142. Application.ScreenUpdating = True
    144. Pivot.Select
    146. End Sub

    Dieser Beitrag wurde bereits 5 mal editiert, zuletzt von „FrankyWill“ ()

    EDIT:

    Ich habe nun meinen vorherigen Code um jeweils eine .Select Anweisung vor den eigentlichen Paste Anweisungen erweitern...siehe da, er gibt mir wieder auf allen Tabellenblätter die korrekten Inhalte aus.

    Woran liegt das, bzw. wie kann ich das eleganter, ohne .Select beheben?

    Quellcode

    1. Option Explicit
    3. Sub Datenimport_Insgesamt()
    5. Dim wbImport As Workbook
    6. Dim ws As Worksheet
    7. Dim wks As Worksheet
    8. Dim wks2 As Worksheet
    9. Dim p As PivotTable
    11. Dim ImportDatei As Variant
    12. Dim CopySheet As Variant
    13. Dim CopyRange As Variant
    15. Dim LetzteZeile2 As Integer
    16. Dim Zeilenanzahl As Integer
    17. Dim Zeilenanzahl2 As Integer
    18. Dim Zeilenanzahl3 As Integer
    19. Dim Spaltenanzahl As Integer
    20. Dim Spaltenanzahl2 As Integer
    21. Dim Spaltenanzahl3 As Integer
    22. Dim zeile As Long
    23. Dim lngSpalte As Long
    24. Dim a As Long
    27. Application.ScreenUpdating = False
    29. Import.Select
    31. 'Öffnet MsgBox "Datei öffnen"
    32. ImportDatei = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.xlsx; *.xlsm; *.xls; *.xlsb),*.xlsx; *.xlsm; *.xls; *.xlsb", Title:="Eine Datei auswählen")
    34. If ImportDatei = False Then
    35. MsgBox "Der Benutzer hat abgebrochen.", vbInformation
    37. Else
    39. Set wbImport = Workbooks.Open(ImportDatei)
    40. Set CopySheet = wbImport.Sheets(1)
    41. Set CopyRange = Intersect(CopySheet.UsedRange, CopySheet.Range("2:" & Rows.Count))
    42. Import.Range(CopyRange.Address).Value = CopyRange.Value
    43. wbImport.Close Savechanges:=False
    45. Import.AutoFilter.Sort.SortFields.Clear
    46. Import.AutoFilter.Sort.SortFields.Add Key:=Range("H2:H65536"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    48. With Import.AutoFilter.Sort
    49. .Header = xlYes
    50. .MatchCase = False
    51. .Orientation = xlTopToBottom
    52. .SortMethod = xlPinYin
    53. .Apply
    54. End With
    55. End If
    57. 'Fehlende Änderungsdatum Angabe ersetzen durch "Angelegt am" Datum
    58. LetzteZeile2 = Range("H65535").End(xlUp).Offset(1, 0).Row
    59. Cells(LetzteZeile2, "H").FormulaR1C1 = "=RC[1]"
    60. Cells(LetzteZeile2, "H").AutoFill Destination:=Range(Cells(LetzteZeile2, "H"), Cells(10000, "H"))
    62. 'Aktuelles Datum in CE1
    63. Range("CE1").FormulaR1C1 = "=TODAY()"
    65. 'Hinter allen Verwendeten Zeilen Datum
    66. Range("J2").FormulaR1C1 = "=IF(ISNONTEXT(RC[-6]),"""",(R1C[73]))"
    67. Range("J2").AutoFill Destination:=Range("J2:J10000")
    69. 'Hinter allen Datumsableitung einfügen
    70. Range("L2").FormulaR1C1 = "=YEAR(RC[-4])"
    71. Range("L2").AutoFill Destination:=Range("L2:L10000")
    73. 'Markiert und Kopiert den benutzten Bereich im Tabellenblatt "Import"
    74. Zeilenanzahl = Import.Cells(Rows.Count, 1).End(xlUp).Row
    75. Spaltenanzahl = Import.Cells(Zeilenanzahl, Columns.Count).End(xlToLeft).Column
    76. Range(Cells(2, 1), Cells(Zeilenanzahl, Spaltenanzahl)).Copy
    78. 'Fügt alles auf Tabellenblatt "Import ohne Dublikate" ein
    79. IoD.Select
    80. IoD.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, _
    81. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    83. 'Dublikate aus Tabellenblatt "Import ohne Dublikate" löschen
    84. IoD.UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
    86. 'Setzt Filter
    87. Import.Select
    88. Import.UsedRange.AutoFilter Field:=6, Criteria1:=Array( _
    89. "MAFR INIT", "MAFR INIT ANGE", "MAFR INIT ANGE ERL", "MAFR INIT ANGE WDER", _
    90. "MAFR INIT ERL", "MAFR INIT ERL WDER", "MAFR INIT ERL WDSP", "MAFR INIT WDSP", _
    91. "MAFR MAH2", "MAFR MAH2 ERL", "MAOF INIT", "MAOF INIT ANGE ERL"), Operator:=xlFilterValues
    93. 'Benutzten, gefilterten Bereich auf "Import" kopieren
    94. Zeilenanzahl2 = Import.Cells(Rows.Count, 1).End(xlUp).Row
    95. Spaltenanzahl2 = Import.Cells(Zeilenanzahl2, Columns.Count).End(xlToLeft).Column
    96. Range(Cells(2, 1), Cells(Zeilenanzahl2, Spaltenanzahl2)).Copy
    98. 'Fügt alles auf Tabellenblatt "nur offene Maßnahmen" ein
    99. noM.Select
    100. noM.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    102. 'Dublikate löschen auf "nur offene Maßnahmen"
    103. ' noM.UsedRange.RemoveDuplicates Columns:=Array(2, 3, 4, 9), Header:=xlYes
    105. Range(Cells(2, 1), Cells(Zeilenanzahl2, Spaltenanzahl2)).Copy
    107. OOD.Select
    108. OOD.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    110. 'Dublikate aus Tabellenblatt "Offen Ohne Dublikate" löschen
    111. OOD.UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
    112. OOD.UsedRange.RemoveDuplicates Columns:=Array(2, 3, 4, 9), Header:=xlYes
    114. 'Filter zurücksetzen auf Tabellenblatt "Import"
    115. Import.Select
    116. Import.UsedRange.AutoFilter Field:=6
    118. 'SAP Datenstand archivieren auf Tabellenblatt "Archiv"
    119. Zeilenanzahl3 = Import.Cells(Rows.Count, 1).End(xlUp).Row
    120. Spaltenanzahl3 = Import.Cells(Zeilenanzahl3, Columns.Count).End(xlToLeft).Column
    121. Range(Cells(2, 1), Cells(Zeilenanzahl3, Spaltenanzahl3)).Copy
    123. Archiv.Select
    124. Archiv.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    126. Archiv.UsedRange.RemoveDuplicates Columns:=Array(2, 3, 4, 10), Header:=xlYes
    128. 'Inhalte in Tabellenblatt Import löschen
    129. Import.Select
    130. Import.Range("A2:L10000").Select
    131. Selection.Clear
    134. IoD.Columns("H:H").NumberFormat = "m/d/yyyy"
    136. noM.Columns("H:H").NumberFormat = "m/d/yyyy"
    138. OOD.Columns("H:H").NumberFormat = "m/d/yyyy"
    140. Archiv.Columns("H:H").NumberFormat = "m/d/yyyy"
    142. 'Pivot Tabellen aktualisieren
    143. For Each ws In ActiveWorkbook.Worksheets
    144. For Each p In ws.PivotTables
    145. p.RefreshTable
    146. Next
    147. Next
    149. Application.ScreenUpdating = True
    151. Pivot.Select
    153. End Sub

    FrankyWill schrieb:

    Ich habe nun meinen vorherigen Code um jeweils eine .Select Anweisung vor den eigentlichen Paste Anweisungen erweitern
    Wenn du ein Select einfügen musst, fehlt in deiner Anweisung die Angabe des Sheet für einen Range.
    Range(Cells(2, 1), Cells(Zeilenanzahl3, Spaltenanzahl3)).Copy gilt für das aktive Sheet.
    Import.Range(Cells(2, 1), Cells(Zeilenanzahl3, Spaltenanzahl3)).Copy gilt überall, weil du das Sheet spezifizierst.

    Aber arbeite besser nicht mit Copy/Paste, sondern weise die Inhalte direkt zu.
    Beispiel:

    FrankyWill schrieb:

    Import.Select
    ...
    Range(Cells(2, 1), Cells(Zeilenanzahl3, Spaltenanzahl3)).Copy
    Archiv.Select
    Archiv.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    kann ersetzt werden durch

    Visual Basic-Quellcode

    1. Set CopyRange = Import.Range(Cells(2, 1), Cells(Zeilenanzahl3, Spaltenanzahl3))
    2. Archiv.Cells(Rows.Count,1).End(xlUp).Offset(1).Resize(CopyRange.Rows.Count, CopyRange.Columns.Count).Value = CopyRange.Value


    Grundregel: Elemente wie .Activate, Active..., .Select, Selection., .Paste... dürfen eigentlich nie vorkommen.
    Die einen, weil sie auf die GUI beeinflussen, was auf die Performance geht.
    Die anderen, weil sie den PasteBuffer verwenden, der gleichzeitig von allen laufenden Anwendungen verwendet wird.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

Facebook
Telefonspende