Follow along with the video below to see how to install our site as a web app on your home screen.
Anmerkung: This feature currently requires accessing the site using the built-in Safari browser.
Ist nicht so schwer
Erklärungen im Code
Visual Basic:Public Sub t405709() Const C_SRC_TABLE = "Tabelle1" 'Name der Quelltabelle Const C_SRC_ADRESS = "A:G" 'zu kopierender Range Const C_TRG_TABLE = "trg" 'Name der Zieltabelle Const C_FILTER_COL = 5 'Spalte zum Filtern (E) Const C_FILTER_VALUE = "Bild" 'Wert zum filtern Dim srcWs As Worksheet: Set srcWs = Worksheets(C_SRC_TABLE) Dim srcRng As Range: Set srcRng = srcWs.Range(C_SRC_ADRESS) Dim trgWs As Worksheet: Set trgWs = Worksheets(C_TRG_TABLE) Dim rowRng As Range Dim bildRow As Long Dim lastTrgRowNr As Long: lastTrgRowNr = -1 Dim blockFlag As Boolean 'Bestehende Daten löschen trgWs.UsedRange.Clear 'Zeilen durchiterieren For Each rowRng In srcRng.rows 'Wenn die ganze Zeile leer ist, aufhören If srcWs.Application.WorksheetFunction.CountA(rowRng) = 0 Then Exit For 'Bildfilter prüfen If rowRng.Cells(1, C_FILTER_COL).value = C_FILTER_VALUE Then blockFlag = False 'Block zurücksetzen bildRow = rowRng.row 'Letzte Bild-Zeile merken ElseIf bildRow > 1 Then 'Falls Blockanfang, die letzte Bildzeile ausgeben If Not blockFlag Then lastTrgRowNr = lastTrgRowNr + 2 'Zielzeile ermitteln (inkl. einer Leerzeile am Anfang) 'Letzte Bild-Zeile kopieren rowRng.Offset(-1).Copy trgWs.Cells(lastTrgRowNr, 1) lastTrgRowNr = lastTrgRowNr + 1 'Plus eine Leerzeile End If blockFlag = True 'Block beginnen lastTrgRowNr = lastTrgRowNr + 1 'Zielzeile ermitteln rowRng.Copy trgWs.Cells(lastTrgRowNr, 1) 'Zeile kopieren End If Next rowRng 'mitkopierte Formate entfernen trgWs.UsedRange.ClearFormats End Sub
- Runtime-Error.Das ist kein Sortierungscode. Das ist ein einfaches zuweisen eines Worksheets. Nix mit sortieren.
Und die Fehlermeldung ist?
Des Weiteren. In welcher Datei wird der Code ausgeführt? In der Zieldatei? In der Quelldatei? In einer dritten unabhängigen Datei?
Sorry..Runtime-Error
Sorry, diese Aussage ist nix Wert. Das ist gleich wie "Es hat ein Fehler". Eine Nummer? Ein Error-Text?
Ist nicht so schwer
Erklärungen im Code
Visual Basic:Public Sub t405709() Const C_SRC_TABLE = "Tabelle1" 'Name der Quelltabelle Const C_SRC_ADRESS = "A:G" 'zu kopierender Range Const C_TRG_TABLE = "trg" 'Name der Zieltabelle Const C_FILTER_COL = 5 'Spalte zum Filtern (E) Const C_FILTER_VALUE = "Bild" 'Wert zum filtern Dim srcWs As Worksheet: Set srcWs = Worksheets(C_SRC_TABLE) Dim srcRng As Range: Set srcRng = srcWs.Range(C_SRC_ADRESS) Dim trgWs As Worksheet: Set trgWs = Worksheets(C_TRG_TABLE) Dim rowRng As Range Dim bildRow As Long Dim lastTrgRowNr As Long: lastTrgRowNr = -1 Dim blockFlag As Boolean 'Bestehende Daten löschen trgWs.UsedRange.Clear 'Zeilen durchiterieren For Each rowRng In srcRng.rows 'Wenn die ganze Zeile leer ist, aufhören If srcWs.Application.WorksheetFunction.CountA(rowRng) = 0 Then Exit For 'Bildfilter prüfen If rowRng.Cells(1, C_FILTER_COL).value = C_FILTER_VALUE Then blockFlag = False 'Block zurücksetzen bildRow = rowRng.row 'Letzte Bild-Zeile merken ElseIf bildRow > 1 Then 'Falls Blockanfang, die letzte Bildzeile ausgeben If Not blockFlag Then lastTrgRowNr = lastTrgRowNr + 2 'Zielzeile ermitteln (inkl. einer Leerzeile am Anfang) 'Letzte Bild-Zeile kopieren rowRng.Offset(-1).Copy trgWs.Cells(lastTrgRowNr, 1) lastTrgRowNr = lastTrgRowNr + 1 'Plus eine Leerzeile End If blockFlag = True 'Block beginnen lastTrgRowNr = lastTrgRowNr + 1 'Zielzeile ermitteln rowRng.Copy trgWs.Cells(lastTrgRowNr, 1) 'Zeile kopieren End If Next rowRng 'mitkopierte Formate entfernen trgWs.UsedRange.ClearFormats End Sub