Zahlenintervalle auflösen

Forumthread: Zahlenintervalle auflösen

12.03.2023 13:56:20

Uwe

Hallo,
in einer mir vorliegenden Excel Datei sind Intervall-Werte in den Spalte A und B definiert.
Spalte A Zeile 2 = 1.000, Spalte B Zeile 2 = 1.003
Spalte A Zeile 3 = 2.009, Spalte B Zeile 3 = 2.013
Spalte A Zeile 4 = 4.001
Spalte A Zeile 5 = 7.008, Spalte B Zeile 5 = 7.015
In der Spalte C sind je Intervall unterschiedliche Merkmale hinterlegt. Bspw. C2 = Auto; C3 = Bus, C4 = Motorrad usw.
Die Tabelle hat mehrere hundert Intervalle, vereinzelt können auch nur Einzelwerte in Spalte A vorkommen. Die Spalte B ist dann leer.
Nun möchte ich über ein Makro die Intervalle auflösen, damit ich alle Einzelwerte aus den Intervallen (Spalte A und B) in einer neuen Tabelle untereinander stehen habe. Das Merkmal aus Spalte C sollte in der danbenstehenden Spalte mit angegeben werden.
Das Ergebnis kann wie folgt aussehen (neues Tabellenblatt)

A2 = 1.000; B2 =Auto
A3 = 1.001; B3 =Auto
A4 = 1.002; B4 =Auto
A5 = 1.003; B5 =Auto
A6 = 2.009; B6 =Bus
A7 = 2.010; B6 =Bus
ff.
A11 = 4.001; B11 =Motorrad
A12 = 7.008; B12 =Fahrrad
ff
Es wäre super, wenn mir jemand helfen kann.
Danke und viele Grüße
Uwe

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Zahlenintervalle auflösen

12.03.2023 14:20:24

GerdL
AW: Zahlenintervalle auflösen

12.03.2023 14:28:15

Nepumuk

AW: Zahlenintervalle auflösen

12.03.2023 14:20:24

GerdL

Hallo Uwe!

Sub Unit()
    Dim wksQuelle As Worksheet
    Dim wksZiel As Worksheet
    
    Set wksQuelle = Worksheets("Tabelle1")
    Set wksZiel = Worksheets("Tabelle2")
    
    With wksQuelle.Columns(2).SpecialCells(4)
        Union(.Offset(, -1), .Offset(, 1)).Copy
        wksZiel.Cells(2, 1).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
    End With
    
    Set wksZiel = Nothing
    Set wksQuelle = Nothing
End Sub

Gruß Gerd

AW: Zahlenintervalle auflösen

12.03.2023 14:28:15

Nepumuk

Hallo Uwe,
teste mal:

Option Explicit
Public Sub Solve_number_intervals()
    Dim avntValues As Variant
    Dim astrOutput() As String
    Dim ialngIndex As Long, ialngCount As Long
    With Worksheets("Tabelle1")
        avntValues = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3)).Value2
    End With
    For ialngIndex = LBound(avntValues) To UBound(avntValues)
        If IsEmpty(avntValues(ialngIndex, 2)) Then
            ReDim Preserve astrOutput(1, ialngCount)
            astrOutput(0, ialngCount) = avntValues(ialngIndex, 1)
            astrOutput(1, ialngCount) = avntValues(ialngIndex, 3)
            ialngCount = ialngCount + 1
        End If
    Next
    Worksheets("Tabelle2").Cells(2, 1).Resize(ialngCount, 2).Value = Application.Transpose(astrOutput)
End Sub

Die Namen der Tabellen anpassen!!!
Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Forumthread: Zahlenintervalle auflösen

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread