Zahlen aus einer Textzelle herausholen und zuordnung

[atilla]

Hallo Marvin

mit ein paar Zeilen Code mehr konnte ich alles umsetzen.
Den gesamten Code hinter Tabelle4 mit folgendem ersetzen:

Code:

Private Sub Worksheet_Activate()
   Call einlesen
End Sub

Sub einlesen()

   Dim varDaten
   Dim arrZiel
   Dim arrBemerkungen
   Dim arrDat
   Dim i As Long, ii As Long, k As Long
   Dim lngZ As Long
   Dim vntS
   
   With Sheets("Tabelle1").Range("A2").CurrentRegion
      varDaten = .Value
      lngZ = .Rows.Count
   End With
   
   arrBemerkungen = Range("F1:K1")
   Range("F2:Q" & lngZ).ClearContents
   arrZiel = Range("F2:Q" & lngZ)
   For i = 2 To lngZ
      If varDaten(i, 1) <> "" Then
         arrDat = Split(varDaten(i, 6), ": ")
         vntS = Application.Match(arrDat(0), arrBemerkungen, 0)
         If IsNumeric(vntS) Then
            arrZiel(i - 1, vntS) = CDbl(arrDat(1))
         End If
         If varDaten(i, 7) <> "" Then
            arrZiel(i - 1, 7) = Val(varDaten(i, 7))
            arrZiel(i - 1, 8) = CDbl(Replace(Split(varDaten(i, 7), "(")(1), ")", ""))
         End If
         arrZiel(i - 1, 9) = Val(varDaten(i, 8))
         arrZiel(i - 1, 10) = Val(varDaten(i, 9))
         arrZiel(i - 1, 11) = WorksheetFunction.Round(Val(varDaten(i, 9)) / CDbl(Replace(Split(varDaten(i, 9), "(")(1), "%)", "")) * 100, 0)
         
      Else
         k = i
         Do While varDaten(k, 1) = ""
            ii = i - 1
            arrDat = Split(varDaten(k, 6), ": ")
            vntS = Application.Match(arrDat(0), arrBemerkungen, 0)
            If IsNumeric(vntS) Then
               arrZiel(ii - 1, vntS) = CDbl(arrDat(1))
            End If
            k = k + 1
         Loop
         i = k - 1
      End If
   Next i
   
   Range("F2:Q" & lngZ) = arrZiel

End Sub

Sobald die Tabelle4 aktiviert wird, wird der obige Code ausgeführt.
Nach Codeausführung sind manche Aktionen nicht mehr möglich, dazu gehört z.B. Rückgängig oder Einfügen über Kontextmenü oder über die Menüleiste.
Du kannst aber über die Zwischenablage gehen und einfügen oder Du schaltest vorher den Entwurfmodus in den Entwicklertools ein, damit der Code nicht ausgeführt wird.

Wenn Du nicht möchtest, dass der Code jedes mal beim aktivieren der Tabelle4 ausgelöst wird, dann lösch folgende Zeilen:

Code:

Private Sub Worksheet_Activate()
   Call einlesen
End Sub

Danach kannst Du den Code einer Schaltfläche zuweisen und manuell starten.

[Marvin26]

Hallo, danke noch für deine Antwort.

Habe mal ein wenig rumprobiert, aber so richtig zurechtkommen tue ich nicht.

Die Werte von den Spalten B C D E werden nicht korrekt übertragen (nur B1, B2, B3 werden übernommen) - kann jemand sagen woran das liegt?

Die anderen Spalten sehen gut aus, nur das bei der letzten Person die Werte nicht in der richtigen Spalte landen.

[schauan]

Hallo Bernd,

der Code ist so programmiert, dass er ab Spalte F Eintragungen vornimmt. Vielleicht, weil in der ursprünglichen Aufgabenstellung auf Spalte F verwiesen wurde

[atilla]

Hallo,

Andre hat es schon geschrieben, der Code untersucht den Bereich ab Spalte F und überträgt nach Vorgabe.

Bei der letzten Person wird auch richtig übertragen, nur Du hast selbst nicht richtig übertragen.
In Tab1 befindet sich zwischen letzter- und vorletzter Person eine Leerzeile.
Das sollte ich beachten und, im Code wird das auch beachtet.
In Tab4 hast Du aber die Personen ohne Leerzeile stehen.

Diese Probleme wirst Du immer wieder haben mit Deinem Aufbau.
Deswegen hatte ich Dir in meinem ersten Beitrag gezeigt, wie man Listen am besten aufbaut und auswertet.