AW: Bestimmte Zellen aus bestimmter Spalte
22.06.2012 10:11:14
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