Bestimmte Zellen aus bestimmter Spalte

Julius · 1970-01-01T00:00:00+00:00

Hallo, ich habe folgendes Problem und zwar habe ich eine größere Tabelle mit vielen Werten. Was ich machen muss ist, aus den Spalte "AG-AN" alle Zellen löschen die nicht den Teilinhalt "Abs." haben. Nun müssten die verbliebenen Werte also z.B. "Anlagevermittlung (§ 1 Abs. 1a Satz 2 Nr. 1 KWG)" etc. genau 54 Zellen nach oben verschoben werden. Abschließend müssten die nun untereinander in einer Spalte stehenden Werte, nebeneinander in eine Zeile aufgereiht werden. Ich hoffe das war einigermaßen verständlich, ich hab mich schon durch einiges an Foren gewälzt aber nichts wirklich gefunden was etwas dezidierter mein Problem behebt. Habe nur sehr oberflächliche Kenntnis von VBA, wäre super wenn mir einer Helfen könnte. MfG, Julius

Franz ich hab mal eine Frage und zwar ist es machbar da eine eine Schleife drauf zu basteln, so dass das Makro durchläuft bis es in der Spalte AB auf die erste Leer Zelle stößt. Die Zellen, die fixiert bleiben sollen, hab ich bereits fixiert alle anderen sollten Schrittweise runtergearbeitet werden.
Ich bin am Suchen, ich denke es müsste eine Do...Until Loop sein, aber ich weiß nicht ob ich da dann den ganzen Code umschreiben muss.
Hier jetzt mal das gesamte Makro.

Sub Webabfrage()
Sheets("Tabelle1").Select
Application.Run "BLPLinkReset"
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & Range("AB578").Value _
, Destination:=Range("AG578"))
.Name = "institutDetails.do?cmd=loadInstitutAction&institutId=123024"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
'Überprüfen Inhalt
Dim rng As Range
For Each rng In Range("$AG$10:$AG$825")
If rng.Value = "Abschlußvermittlung (§ 1 Abs. 1a Satz 2 Nr. 2 KWG)" Or rng.Value = " _
Anlageverwaltung (§ 1 Abs. 1a Satz 2 Nr. 11 KWG)" Or rng.Value = "Factoring (§ 1 Abs. 1a Satz 2 Nr. 9 KWG)" Then
Range("$AG$1") = "1"
End If
Next
'Select what to do
For Each rng In Range("$AG$10:$AG$825")
If Range("$AG$1") = "" Then
Dim var As Variant
Dim iRow As Integer, iRowL As Integer
iRowL = Cells(Rows.Count, 1).End(xlUp).Row
For iRow = iRowL To 1 Step -1
var = Application.Match("*BaFin (Link zur Startseite)*", Rows(iRow), 0)
If Not IsError(var) Then
Rows(iRow).Delete
End If
Next iRow
End If
Next
'Delete Useless Content
Range("AG:AG").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="*Factoring*", Operator:=xlOr, _
Criteria2:="*Leasing*"
Range("$AG$1:$AN$887").ClearContents
'Zelle wählen
Range("AG632").Select
'Suchen Transponieren Abs
Dim wks As Worksheet
Dim ZelleStart As Range
Dim DeltaZeile As Long
Dim Bereich As Range, Zeile_L As Long
Set wks = ActiveSheet
DeltaZeile = 54 'Anzeilen, um die die Zellen mit "Abs." nach oben verschoben werden sollen
Set ZelleStart = Selection
'Wordbox ehemalig
With wks
'falls aktiv, dann Autofilter deaktivieren
If .AutoFilterMode = True Then
If .FilterMode = True Then .ShowAllData
.AutoFilterMode = False
End If
'Prüfen von Spalte und Zeile der selektierten Startzelle
If ZelleStart.Column = .Range("$AG$1").Column _
And ZelleStart.Row > DeltaZeile _
And ZelleStart.Cells.Count = 1 Then
'Selektion ist ok
Else
MsgBox "Startzelle für Makro muss einzelne Zelle in Spalte AG sein, " _
& "unterhalb von Zeile " & DeltaZeile, _
vbInformation + vbOKOnly, _
"Selektierte Zelle: " & ZelleStart.Address
Exit Sub
End If
'letzte Datenzeile in Spalten AG:AN
With .Range("AG:AN")
Set Bereich = .Find(after:=.Range("A1"), What:="*", LookIn:=xlFormulas, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
End With
If Bereich Is Nothing Then
MsgBox " Keine Daten in Spalten AG:AN"
Exit Sub
Else
Zeile_L = Bereich.Row
If Zeile_L *Abs.*"
'Inhalt in sichtbaren Zellen löschen
Set Bereich = .Range(ZelleStart.Offset(1, 0), .Cells(Zeile_L, ZelleStart.Column))
Bereich.ClearContents
wks.ShowAllData
wks.AutoFilterMode = False
'leere Zellen löschen
If Application.WorksheetFunction.CountBlank(Bereich) > 0 Then
Bereich.SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp
End If
'neue Letztezeile in Spalte AG
Zeile_L = .Cells(.Rows.Count, ZelleStart.Column).End(xlUp).Row
If Zeile_L *Abs.*", Operator:=xlAnd
Selection.ClearContents
Range("AG578").Select
End Sub

Hallo Franz,
ich würde gerne das Makro von solange durchlaufen lassen, bis es in Spalte A auf eine leere Zelle trifft. Ich hab ein bisschen recherchiert ich denke es müsst eine Do...Until Loop sein, aber bei der Komplexität vom Makro kann ich die Schleife schlicht weg nicht umsetzten, weil ich nicht weiß wie man das Makro richtig konditioniert, sodass nur die richitgen Zellen betroffen werden.
Hier der Code, fyi die fixierten Zellen hab ich bewusst fixiert :)

Sub Webabfrage()
Sheets("Tabelle1").Select
Application.Run "BLPLinkReset"
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & Range("AB578").Value _
, Destination:=Range("AG578"))
.Name = "institutDetails.do?cmd=loadInstitutAction&institutId=123024"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
'Überprüfen Inhalt
Dim rng As Range
For Each rng In Range("$AG$10:$AG$825")
If rng.Value = "Abschlußvermittlung (§ 1 Abs. 1a Satz 2 Nr. 2 KWG)" Or rng.Value = " _
Anlageverwaltung (§ 1 Abs. 1a Satz 2 Nr. 11 KWG)" Or rng.Value = "Factoring (§ 1 Abs. 1a Satz 2 Nr. 9 KWG)" Then
Range("$AG$1") = "1"
End If
Next
'Select what to do
For Each rng In Range("$AG$10:$AG$825")
If Range("$AG$1") = "" Then
Dim var As Variant
Dim iRow As Integer, iRowL As Integer
iRowL = Cells(Rows.Count, 1).End(xlUp).Row
For iRow = iRowL To 1 Step -1
var = Application.Match("*BaFin (Link zur Startseite)*", Rows(iRow), 0)
If Not IsError(var) Then
Rows(iRow).Delete
End If
Next iRow
End If
Next
'Delete Useless Content
Range("AG:AG").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="*Factoring*", Operator:=xlOr, _
Criteria2:="*Leasing*"
Range("$AG$1:$AN$887").ClearContents
'Zelle wählen
Range("AG632").Select
'Suchen Transponieren Abs
Dim wks As Worksheet
Dim ZelleStart As Range
Dim DeltaZeile As Long
Dim Bereich As Range, Zeile_L As Long
Set wks = ActiveSheet
DeltaZeile = 54 'Anzeilen, um die die Zellen mit "Abs." nach oben verschoben werden sollen
Set ZelleStart = Selection
'Wordbox ehemalig
With wks
'falls aktiv, dann Autofilter deaktivieren
If .AutoFilterMode = True Then
If .FilterMode = True Then .ShowAllData
.AutoFilterMode = False
End If
'Prüfen von Spalte und Zeile der selektierten Startzelle
If ZelleStart.Column = .Range("$AG$1").Column _
And ZelleStart.Row > DeltaZeile _
And ZelleStart.Cells.Count = 1 Then
'Selektion ist ok
Else
MsgBox "Startzelle für Makro muss einzelne Zelle in Spalte AG sein, " _
& "unterhalb von Zeile " & DeltaZeile, _
vbInformation + vbOKOnly, _
"Selektierte Zelle: " & ZelleStart.Address
Exit Sub
End If
'letzte Datenzeile in Spalten AG:AN
With .Range("AG:AN")
Set Bereich = .Find(after:=.Range("A1"), What:="*", LookIn:=xlFormulas, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
End With
If Bereich Is Nothing Then
MsgBox " Keine Daten in Spalten AG:AN"
Exit Sub
Else
Zeile_L = Bereich.Row
If Zeile_L *Abs.*"
'Inhalt in sichtbaren Zellen löschen
Set Bereich = .Range(ZelleStart.Offset(1, 0), .Cells(Zeile_L, ZelleStart.Column))
Bereich.ClearContents
wks.ShowAllData
wks.AutoFilterMode = False
'leere Zellen löschen
If Application.WorksheetFunction.CountBlank(Bereich) > 0 Then
Bereich.SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp
End If
'neue Letztezeile in Spalte AG
Zeile_L = .Cells(.Rows.Count, ZelleStart.Column).End(xlUp).Row
If Zeile_L *Abs.*", Operator:=xlAnd
Selection.ClearContents
Range("AG578").Select
End Sub

Wäre super wenn du da helfen könntest! Oder irgendjemand anderes natürlich auch

Bestimmte Zellen aus bestimmter Spalte

Forumthread: Bestimmte Zellen aus bestimmter Spalte

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Bestimmte Zellen aus bestimmter Spalte

Forumthread: Bestimmte Zellen aus bestimmter Spalte

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread