Zell wert auslesen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Monika,
da du nicht schreibst, wo sich die Einträge befinden und was mit dem Ergebnis geschehen soll, mal ein Beispielcode der von Spalte A ab Zeile 1 ausgeht und die Ergebnisse in einer MsgBox anzeigt:

Option Explicit
Private Declare Function SafeArrayGetDim Lib "oleaut32" (pArray() As Any) As Long
Public Sub Monika()
    Dim bolFound As Boolean
    Dim intIndex As Integer, intStart As Integer
    Dim lngRow As Long, lngIndex As Long
    Dim strTemp As String
    Dim strArray() As String
    Dim dblArray() As Double
    For lngRow = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        intStart = 1
        For intIndex = 1 To Len(Cells(lngRow, 1))
            If Mid(Cells(lngRow, 1), intIndex, 1) = " " Or intIndex = Len(Cells(lngRow, 1)) Then
                strTemp = Mid(Cells(lngRow, 1), intStart, intIndex - intStart + 1 * ((intIndex = Len(Cells(lngRow, 1))) * -1))
                If SafeArrayGetDim(strArray()) Then
                    For lngIndex = 1 To UBound(strArray)
                        If strArray(lngIndex) = Right$(strTemp, 1) Then bolFound = True: Exit For
                    Next
                Else
                    ReDim Preserve strArray(1 To 1)
                    ReDim Preserve dblArray(1 To 1)
                    strArray(UBound(strArray)) = Right$(strTemp, 1)
                    lngIndex = 1
                    bolFound = True
                End If
                If bolFound Then
                    dblArray(lngIndex) = dblArray(lngIndex) + Val(strTemp)
                    bolFound = False
                Else
                    ReDim Preserve strArray(1 To UBound(strArray) + 1)
                    ReDim Preserve dblArray(1 To UBound(dblArray) + 1)
                    strArray(UBound(strArray)) = Right$(strTemp, 1)
                    dblArray(UBound(dblArray)) = Val(strTemp)
                End If
                intStart = intIndex + 1
            End If
        Next
    Next
    For lngIndex = 1 To UBound(strArray)
        MsgBox CStr(dblArray(lngIndex)) & " " & strArray(lngIndex)
    Next
End Sub

Gruß
Nepumuk

Hallo Monika,
ich habe das Programm noch etwas geändert. Du musst in den zwei gekennzeichneten Zeilen nur noch die Tabellennamen noch anpassen.

Option Explicit
Private Declare Function SafeArrayGetDim Lib "oleaut32" (pArray() As Any) As Long
Public Sub Monika()
    Dim bolFound As Boolean
    Dim intIndex As Integer, intStart As Integer
    Dim lngRow As Long, lngIndex As Long
    Dim strTemp As String
    Dim strArray() As String
    Dim dblArray() As Double
    With Worksheets("Tabelle1") 'Tabelle1 = Eingabetabelle
        For lngRow = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
            intStart = 1
            For intIndex = 1 To Len(.Cells(lngRow, 1))
                If Mid(.Cells(lngRow, 1), intIndex, 1) = " " Or intIndex = Len(.Cells(lngRow, 1)) Then
                    strTemp = Mid(.Cells(lngRow, 1), intStart, intIndex - intStart + 1 * ((intIndex = Len(.Cells(lngRow, 1))) * -1))
                    If SafeArrayGetDim(strArray()) Then
                        For lngIndex = 1 To UBound(strArray)
                            If strArray(lngIndex) = Right$(strTemp, 1) Then bolFound = True: Exit For
                        Next
                    Else
                        ReDim Preserve strArray(1 To 1)
                        ReDim Preserve dblArray(1 To 1)
                        strArray(UBound(strArray)) = Right$(strTemp, 1)
                        lngIndex = 1
                        bolFound = True
                    End If
                    If bolFound Then
                        dblArray(lngIndex) = dblArray(lngIndex) + Val(strTemp)
                        bolFound = False
                    Else
                        ReDim Preserve strArray(1 To UBound(strArray) + 1)
                        ReDim Preserve dblArray(1 To UBound(dblArray) + 1)
                        strArray(UBound(strArray)) = Right$(strTemp, 1)
                        dblArray(UBound(dblArray)) = Val(strTemp)
                    End If
                    intStart = intIndex + 1
                End If
            Next
        Next
    End With
    If SafeArrayGetDim(strArray()) Then
        For lngIndex = 1 To UBound(strArray)
            Worksheets("Tabelle2").Cells(1, lngIndex) = CStr(dblArray(lngIndex)) & " " & strArray(lngIndex) ' Tabelle2 = Ausgabetabelle
        Next
    End If
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread