Definierte Werte über Markos einfügen

[FelixFelix29]

Hallo in die Runde,

folgende Problematik: Ich habe eine Excel-Datei mit zwei Datenblättern "Datenanalyse (automatisch)" und "Datenspeicherung (automatisch).
Ich habe nun Werte aus dem Quelldatenblatt (Datenanalyse (automatisch)) die in das Zieldatenblatt (Datenspeicherung (automatisch)) kopiert werden sollen wenn
ich auf einen Button klicke. Die Werte sind dabei später durch verschiedene Formeln berechnet.

Immer wenn ich auf den Button klicke sollen die Daten kopiert werden und zwar in die nächst leere Spalte.

Ein Mitglied dieses Forums hat mir bereits ein Makros zukommen lassen, welches perfekt funktioniert. Alle in der Mustertabelle gelb und grün markierten Werte werden kopiert und es wird immer die nächst leere Spalte im Zieldatenblatt genutzt.

Jetzt zur eigentlichen Thematik: Jedes Mal wenn das Markos ausgeführt wird und die Daten kopiert werden soll automatisch die dazugehörige (wenn vorhanden) Benchmark mit eingefügt werden. Das sind die grau eingetragenen Werte. 

Ich hoffe ich habe die Thematik verständlich erklärt und hoffe es kann mir jemand weiterhelfen. Danke schon Mal!

VG Felix

Sub x()
    Dim arr As Variant
    Dim i As Long
    Dim j As Long
    Dim col As Long
   
    arr = Worksheets("Datenanalyse (automatisch)").Range("A1:F42")
   
    With Worksheets("Datenspeicherung (automatisch)")
        col = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
         .Cells(1, col) = arr(3, 2)
         j = 2
         For i = 6 To 15
         
            .Cells(j, col) = arr(i, 6)
            .Cells(j + 1, col) = arr(i, 5)
            j = j + 3
         Next i
         For i = 19 To 28
            .Cells(j, col) = arr(i, 6)
            .Cells(j + 1, col) = arr(i, 5)
            j = j + 3
         Next
       
         For i = 32 To 42
            .Cells(j, col) = arr(i, 3)
            j = j + 1
         Next
       
        .Columns(2).Copy
        .Columns(col).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False

    End With
End Sub

[UweD]

Hallo

...und es wird immer die nächst leere Spalte im Zieldatenblatt genutzt.


Jetzt zur eigentlichen Thematik: Jedes Mal wenn das Markos ausgeführt wird und die Daten kopiert werden soll automatisch die dazugehörige (wenn vorhanden) Benchmark mit eingefügt werden. Das sind die grau eingetragenen Werte. 

Ich hoffe ich habe die Thematik verständlich erklärt und hoffe es kann mir jemand weiterhelfen. Danke schon Mal!

VG Felix

Die Änderung war mal von mir.

Hier der Code für die Benchmarks.
Die Sonderwünsche sind mit abgearbeitet
 kleinergleich, größergleich sowie das 1 :  werden gelöscht
 bei von - bis wird nur der hintere Teil verwendet

Code:

Sub x()
    Dim arr As Variant
    Dim i As Long
    Dim j As Long
    Dim col As Long
    Dim Bench As String
  
    arr = Worksheets("Datenanalyse (automatisch)").Range("A1:F42")
  
    With Worksheets("Datenspeicherung (automatisch)")
        col = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
         .Cells(1, col) = arr(3, 2)
         j = 2
         For i = 6 To 15
        
            .Cells(j, col) = arr(i, 6)
            .Cells(j + 1, col) = arr(i, 5)
           
            Bench = CStr(arr(i, 4))
            Bench = Replace(Bench, ChrW(8804) & " ", "") 'KleinerGleich
            Bench = Replace(Bench, ChrW(8805) & " ", "") 'GrößerGleich
            Bench = Replace(Bench, "1 : ", "")           ' 1: entfernen
            If InStr(Bench, "-") > 0 Then   'von bis entfernen
                Bench = Mid(Bench, InStr(Bench, "-") + 1)
            End If
            .Cells(j + 2, col) = Bench
            j = j + 3
         Next i
         For i = 19 To 28
            .Cells(j, col) = arr(i, 6)
            .Cells(j + 1, col) = arr(i, 5)
           
            Bench = CStr(arr(i, 4))
            Bench = Replace(Bench, ChrW(8804) & " ", "") 'KleinerGleich
            Bench = Replace(Bench, ChrW(8805) & " ", "") 'GrößerGleich
            Bench = Replace(Bench, "1 : ", "")           ' 1: entfernen
            If InStr(Bench, "-") > 0 Then   'von bis entfernen
                Bench = Mid(Bench, InStr(Bench, "-") + 1)
            End If
            .Cells(j + 2, col) = Bench
            j = j + 3
         Next
      
         For i = 32 To 42
            .Cells(j, col) = arr(i, 3)
            j = j + 1
         Next
      
        .Columns(2).Copy
        .Columns(col).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False

    End With
End Sub

LG UweD

[FelixFelix29]

Top Danke, Uwe. Funktioniert wie beim letzten Mal einwandfrei!

[FelixFelix29]

Hallo - kleines Problem.
das Markos funktioniert an sich. Die Benchmarks werden nun deklariert als "Text gespeicherte Zahl". Ich benötige die Werte, um Diagramme zu erstellen.
Bedeutet ich benötige die Benchmarks als Zahlen definiert. Kann man den Markos dementsprechend anpassen oder tun sich hier Grenzen auf?

VG Felix

---

Hallo


Die Änderung war mal von mir.

Hier der Code für die Benchmarks.
Die Sonderwünsche sind mit abgearbeitet
 kleinergleich, größergleich sowie das 1 :  werden gelöscht
 bei von - bis wird nur der hintere Teil verwendet

Code:

Sub x()
    Dim arr As Variant
    Dim i As Long
    Dim j As Long
    Dim col As Long
    Dim Bench As String
  
    arr = Worksheets("Datenanalyse (automatisch)").Range("A1:F42")
  
    With Worksheets("Datenspeicherung (automatisch)")
        col = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
         .Cells(1, col) = arr(3, 2)
         j = 2
         For i = 6 To 15
        
            .Cells(j, col) = arr(i, 6)
            .Cells(j + 1, col) = arr(i, 5)
           
            Bench = CStr(arr(i, 4))
            Bench = Replace(Bench, ChrW(8804) & " ", "") 'KleinerGleich
            Bench = Replace(Bench, ChrW(8805) & " ", "") 'GrößerGleich
            Bench = Replace(Bench, "1 : ", "")           ' 1: entfernen
            If InStr(Bench, "-") > 0 Then   'von bis entfernen
                Bench = Mid(Bench, InStr(Bench, "-") + 1)
            End If
            .Cells(j + 2, col) = Bench
            j = j + 3
         Next i
         For i = 19 To 28
            .Cells(j, col) = arr(i, 6)
            .Cells(j + 1, col) = arr(i, 5)
           
            Bench = CStr(arr(i, 4))
            Bench = Replace(Bench, ChrW(8804) & " ", "") 'KleinerGleich
            Bench = Replace(Bench, ChrW(8805) & " ", "") 'GrößerGleich
            Bench = Replace(Bench, "1 : ", "")           ' 1: entfernen
            If InStr(Bench, "-") > 0 Then   'von bis entfernen
                Bench = Mid(Bench, InStr(Bench, "-") + 1)
            End If
            .Cells(j + 2, col) = Bench
            j = j + 3
         Next
      
         For i = 32 To 42
            .Cells(j, col) = arr(i, 3)
            j = j + 1
         Next
      
        .Columns(2).Copy
        .Columns(col).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False

    End With
End Sub

LG UweD

Hallo - kleines Problem.
das Markos funktioniert an sich. Die Benchmarks werden nun deklariert als "Text gespeicherte Zahl". Ich benötige die Werte, um Diagramme zu erstellen.
Bedeutet ich benötige die Benchmarks als Zahlen definiert. Kann man den Markos dementsprechend anpassen oder tun sich hier Grenzen auf?

VG Felix

[HKindler]

Hi,

die variable Bench ist als String definiert. Daher wird die "Zahl" als Text in die Zelle geschrieben. Z.B. mit der Zeile

Code:

.Cells(j + 2, col) = Bench

Wenn hier eine Zahl in der Zelle landen soll, musst du den Text umwandeln:

Code:

.Cells(j + 2, col) = CLng(Bench). 'oder CDbl falls es eine Kommazahl ist

[FelixFelix29]

Mit dem angepassten Code funktioniert es leider nicht:

Sub Analyse_Speichern2()

    Dim arr As Variant
    Dim i As Long
    Dim j As Long
    Dim col As Long
    Dim Bench As String
 
    arr = Worksheets("Datenanalyse (automatisch)").Range("A1:F42")
 
    With Worksheets("Datenspeicherung (automatisch)")
        col = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
        .Cells(1, col) = arr(3, 2)
        j = 2
        For i = 6 To 15
       
            .Cells(j, col) = arr(i, 6)
            .Cells(j + 1, col) = arr(i, 5)
         
            Bench = CStr(arr(i, 4))
            Bench = Replace(Bench, ChrW(8804) & " ", "") 'KleinerGleich
            Bench = Replace(Bench, ChrW(8805) & " ", "") 'GrößerGleich
            Bench = Replace(Bench, "1 : ", "")          ' 1: entfernen
            If InStr(Bench, "-") > 0 Then  'von bis entfernen
                Bench = Mid(Bench, InStr(Bench, "-") + 1)
            End If
            .Cells(j + 2, col) = CDbl(Bench)
            j = j + 3
        Next i
        For i = 19 To 28
            .Cells(j, col) = arr(i, 6)
            .Cells(j + 1, col) = arr(i, 5)
         
            Bench = CStr(arr(i, 4))
            Bench = Replace(Bench, ChrW(8804) & " ", "") 'KleinerGleich
            Bench = Replace(Bench, ChrW(8805) & " ", "") 'GrößerGleich
            Bench = Replace(Bench, "1 : ", "")          ' 1: entfernen
            If InStr(Bench, "-") > 0 Then  'von bis entfernen
                Bench = Mid(Bench, InStr(Bench, "-") + 1)
            End If
            .Cells(j + 2, col) = CDbl(Bench)
            j = j + 3
        Next
     
        For i = 32 To 42
            .Cells(j, col) = arr(i, 3)
            j = j + 1
        Next
     
        .Columns(2).Copy
        .Columns(col).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False

    End With
End Sub

[HKindler]

Wow,

nach 6 Tagen eine Reaktion. Wahnsinn! Weist du wie mühsam es für uns Helfer ist, sich nach 6 Tagen wieder an das Problem zu erinnern? Und hättest du dich mit einem Danke gemeldet, wenn es problemlos funktioniert hätte?

Soviel zum anständigen Umgang untereinander. Dazu gehört auch, das man Code in Code-Tags setzt.

Zum Problem: es wäre Hilfreich, wenn du dazu schreiben würdest, was genau nicht funktioniert. Das würde einen Lösungsansatz deutlich vereinfachen. Ich bin jetzt mal davon ausgegangen, dass es immer noch die selbe Datei ist und habe deine letzte Version heruntergeladen und dort den eben gezeigten Code eingefügt. Wenn ich jetzt den Code starte, dann springt der Debugger in der Zeile nach dem ersten "End If" an und zeigt einen "Laufzeitfehler 13: Typenkonflikt" an. Sieht man sich den Inhalt von "Bench" zu diesem Zeitpunkt an, dann steht dort "5,00%". Und das ist für CDbl() leider keine Zahl und kann daher nicht umgewandelt werden. Also sorgen wir dafür, dass VBA bzw. Excel diesen Streng direkt beim Eintrag in eine Zahl umwandelt. Dazu müssen wir nur das Komma in einen Punkt umwandeln (übrigens CDbl() würde das automatisch machen, kommt aber mit dem % nicht klar). Also füge die Zeile

Code:

Bench = Replace(Bench, ",", ".")    'Komma durch Punkt ersetzen (amerikanische Zahl)

zu den Replace-Orgien hinzu und lösche das CDbl() wieder.

Noch ein Tipp zum Schluss: lass in der Formatierung der Zellen das unsägliche Zentrieren sein, dann fallen solche "Fehler" wie "Text statt Zahl" viel früher auf, denn Zahlen werden von Excel automatisch rechtsbündig und Texte linksbündig gesetzt, da sieht man dann sofort ob 5% als Zahl oder Text in der Zelle steht.

[FelixFelix29]

Hallo,

entschuldige bitte die späte Rückmeldung - die Umstände ließen es leider nicht zu..

Ich danke dir für deine Mühen. Mit der Anpassung funktioniert es einwandfrei. Danke! 

VG Felix

[snb]

In VBA:

Code:

Sub M_snb()
  sn = Tabelle1.Range("A1:F42")
  sp = Tabelle2.UsedRange.Columns(2)
  sp(1, 1) = sn(3, 2)
 
  For j = 6 To 15 Step 2
    sp(j, 1) = sn(j, 6)
  Next
  For i = 19 To 28 Step 3
    sp(j, 1) = sn(j, 6)
  Next
  For j = 32 To 42
    sp(j, 1) = sn(j, 3)
  Next

  Tabelle2.UsedRange.Columns(2) = sp
End Sub