VBA Spalte nach Variable ansprechen und Range ist leer

Forumthread: VBA Spalte nach Variable ansprechen und Range ist leer

05.10.2024 10:55:18

Dorit

Hallo,

erneut versuche ich mich an VBA, um Daten von einem Arbeitsblatt in ein anderes Datenblatt zu kopieren und umzustrukturieren.

Aus "BTs Biodiv" Spalte R sollen nicht leere Zellen gefiltert werden, dann soll Spalte A in "BTs Ausw. Diagn." Spalte E kopiert werden. Das funktioniert soweit, nur daß der Filter nicht im richtigen Bereich wirkt und immer die erste Zeile mit ausgibt, obwohl sie leer ist.

Und irgendwie streikt die Formel, wenn der Filter keine Zeilen findet. Ich habe versucht, das abzufragen mit if, then, else, aber es funktioniert nicht...

Dann sollen die dazugehörigen Stetigkeiten aus "BTs Biodiv" in "BTs Ausw. Diagn." Spalte F kopiert werden. Die Anwahl der zu kopierenden Spalte in "BTs Biodiv" soll über den Wert in Spalte R, Zeile 1 im Bereich Spalte A bis P gesucht werden. Ich kriege es leider nicht hin, diese Suche in VBA anzusprechen.

Ich würde mich total freuen, wenn sich ein sachverständiger Mensch findet und mir hilft!

Hier die Beispieltabelle: https://www.herber.de/bbs/user/172588.xlsm

Vielen Dank schonmal!

Liebe Grüße,
Dorit

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: VBA Spalte nach Variable ansprechen und Range ist leer

05.10.2024 13:16:03

ralf_b
Lösungsvorschlag

05.10.2024 14:53:59

ralf_b
AW: Lösungsvorschlag

05.10.2024 20:48:00

Dorit
AW: Lösungsvorschlag

06.10.2024 02:34:11

ralf_b

AW: VBA Spalte nach Variable ansprechen und Range ist leer

05.10.2024 13:16:03

ralf_b

setzte den Autofilterbereich schon ab A3,
die range ,welche SpecialCells(xlCellTypeVisible) zurückgibt ist im Falle von keinem Treffer Nichts. Also frage z.b. mit "if not rng is Nothing then" ab um den Fehler abzufangen.

Lösungsvorschlag

05.10.2024 14:53:59

ralf_b

Ich weis zwar nicht ob das am Ende so aussehen soll, aber du kannst es dir ja mal ansehen.

Option Explicit



Sub CopyDiagnostik()

    

    Dim x As Long, FinalRow1 As Long

    Dim wsTab1 As Worksheet

    Dim wsTab2 As Worksheet

    Dim rng As Range, FilterRange As Range

    

    Application.ScreenUpdating = False 'Zeitgewinn durch Abschalten der Bildschirmaktualisierung

    Application.Calculation = xlCalculationManual 'Zeitgewinn durch Abschalten der Zellberechnung

    

    Set wsTab1 = Worksheets("BTs Biodiv") 'objectvariable auf blatt1 gesetzt

    Set wsTab2 = Worksheets("BTs Ausw. Diagn.")

    

    x = 18 'Beginn Schleife ab Spalte "R"

    

   

        

    With wsTab1

                  

        Do While wsTab1.Cells(1, x).Value > vbNullString ' schleife bis kein wert in zeile 1 spalte x

         

            'Spalten x in "BTs Biodiv" filtern

            .AutoFilterMode = False  'evtl.Filter ausschalten

            Set FilterRange = Range(.Range("A3"), .UsedRange.SpecialCells(xlCellTypeLastCell))

               

            FilterRange.Rows(1).AutoFilter Field:=x, Criteria1:=">" 'filter auf Spalte setzen

                             

            'Spalten 1 in "BTs Ausw. Diagn." kopieren

            On Error Resume Next

            Set rng = FilterRange.Offset(1).Resize(FilterRange.Rows.Count - 1, FilterRange.Columns.Count).SpecialCells(xlCellTypeVisible)

            On Error GoTo 0

            If rng Is Nothing Then

                .AutoFilterMode = False   'Filter ausschalten

                     

            Else

                'erste leere zelle in "BTs Ausw. Diagn." Spalte 1 ermitteln

                FinalRow1 = wsTab2.Cells(Rows.Count, 1).End(xlUp).Row + 1

                   

                wsTab2.Cells(FinalRow1, 1).Resize(rng.Rows.Count, 1).Value = .Cells(3, 17)

                wsTab2.Cells(FinalRow1, 2).Resize(rng.Rows.Count, 1).Value = .Cells(2, 17)

                wsTab2.Cells(FinalRow1, 3).Resize(rng.Rows.Count, 1).Value = .Cells(1, x)

                wsTab2.Cells(FinalRow1, 4).Resize(rng.Rows.Count, 1).Value = .Cells(3, x)

                wsTab2.Cells(FinalRow1, 5).Resize(rng.Rows.Count, 1).Value = WorksheetFunction.Index(rng, 0, 1)

                wsTab2.Cells(FinalRow1, 6).Resize(rng.Rows.Count, 1).Value = WorksheetFunction.Index(rng, 0, x)

                                

            End If

                   

            'Filter ausschalten

            .AutoFilterMode = False

            

            x = x + 1 'spaltenzähler hochsetzen

        Loop

    End With

    

    wsTab2.UsedRange.Columns.AutoFit

      

    'Zurücksetzen der Zeitgewinnoptionen

    Application.Calculation = xlCalculationAutomatic

    Application.ScreenUpdating = True 'unnötig, wird automatisch zurückgesetzt

End Sub

AW: Lösungsvorschlag

05.10.2024 20:48:00

Dorit

Guten Abend, Ralf,

vielen Dank für den Vorschlag.

Der ging soweit gut durch, hat aber immer nur eine Zeile pro Spalte ausgegeben, sowohl, wenn mehrere Zeilen gefiltert wurden, als auch, wenn keine Zeile gefiltert wurde. In letztem Fall kam immer die zuvor übertragene Art nochmal.

Ich habe jetzt Deinen ersten Vorschlag übernommen, A3 in den Autofilterbereich genommen und zum Schluß die zusätzlichen Zeilen wieder gelöscht... ist zwar nicht so elegant und braucht wohl mehr Rechenleistung als nötig, aber hat funktioniert.

Liebe Grüße,
Dorit

AW: Lösungsvorschlag

06.10.2024 02:34:11

ralf_b

Hallo Dorit,
anbei eine Anpassung,
Leider muß man bei den gefilterten Ranges durch die Areas der Range schleifen. Das hatte ich übersehen. Es wird sonst nur der erste Bereich(Area) einer Range übergeben.

es ist zusätzlich noch zu deklarieren.
a as Range , rowscnt as Long

If rng Is Nothing Then

                .AutoFilterMode = False   'Filter ausschalten

                     

            Else

                rowscnt = rng.Cells.CountLarge / rng.Columns.Count

                

                'erste leere zelle in "BTs Ausw. Diagn." Spalte 1 ermitteln

                FinalRow1 = wsTab2.Cells(Rows.Count, 1).End(xlUp).Row + 1

                   

                wsTab2.Cells(FinalRow1, 1).Resize(rowscnt, 1).Value = .Cells(3, 17)

                wsTab2.Cells(FinalRow1, 2).Resize(rowscnt, 1).Value = .Cells(2, 17)

                wsTab2.Cells(FinalRow1, 3).Resize(rowscnt, 1).Value = .Cells(1, x)

                wsTab2.Cells(FinalRow1, 4).Resize(rowscnt, 1).Value = .Cells(3, x)



                For Each a In rng.Areas

                   wsTab2.Cells(FinalRow1, 5).Resize(a.Rows.Count, 1).Value = a.Cells(1)

                   wsTab2.Cells(FinalRow1, 6).Resize(a.Rows.Count, 1).Value = a.Cells(x)

                   FinalRow1 = FinalRow1 + a.Rows.Count

                Next

                

            End If

Beliebteste Forumthreads (12 Monate)

VBA Spalte nach Variable ansprechen und Range ist leer

Forumthread: VBA Spalte nach Variable ansprechen und Range ist leer

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread