VBA Code

[Maximus]

Hallo,
habe folgendes Problem. Wäre schön wenn mir jemand helfen könnte.
 
 
Im Arbeitsblatt Kopie1 in AG6 erzeuge ich einen Eintrag wenn ich das Kontrollkästchen U6 einen Haken setze.
Durch ein VBA-Programm wird der Inhalt dieser Zelle in das Arbeitsblatt Spielabschnitt H2 übertragen.
Das funktioniert durch ein VBA Programm, welches in Modul 2 steht. (VBA-Programm siehe unten)
Das funktioniert gut.

Mein Problem ist jetzt folgendes:
Durch das VBA-Programm möchte ich aber AG6, AG9, AG12, AG15, AG23, AG26, AG29, AG32, AG40, AG43, AG46, AG49 in das Arbeitsblatt Spielabschnitt H2 übertragen.
Das VBA-Programm habe ich dementsprechend erweitert.
Nur in einer Zelle von AG ist Eintrag, abhängig welches Kontrollkäschen ich im Vorwege betätigt habe.
Aber durch das VBA-Programm lasse ich immer alle AG Zellen in das Arbeitsblatt Spielabschnitt übertragen.
Und alle Überträge gehen in H2.
Das Problem ist derzeit dass nach Übertrag in H2 nichts steht, weil ja auch die leeren Zellen übertragen werden.
Ich dachte, da ja nur in einer AG ein Eintrag ist, dass trotzdem in H2 dann halt der Eintrag übertragen wird.
Passiert aber nicht. Das Programm überträgt auch die leeren Zellen.
Kann man da am VBA Programm was ändern dass trotz Übertrag aller AG Zellen in H2 der eine Eintrag zu sehen ist.

Gruss Markus





Sub kopieren()

    Range("M1:M2").Select
    Selection.Copy
    
    Sheets("Spielabschnitt").Select
    Range("AR1").PasteSpecial Paste:=xlPasteValues
   
Sheets(Range("AR1").Value).Select
    Range("AG6").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
         
Sheets(Range("AR1").Value).Select
    Range("AG9").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
         
Sheets(Range("AR1").Value).Select
    Range("AG12").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
         
Sheets(Range("AR1").Value).Select
    Range("AG15").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
         
Sheets(Range("AR1").Value).Select
    Range("AG23").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
         
Sheets(Range("AR1").Value).Select
    Range("AG26").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
         
Sheets(Range("AR1").Value).Select
    Range("AG29").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
         
Sheets(Range("AR1").Value).Select
    Range("AG32").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
         
Sheets(Range("AR1").Value).Select
    Range("AG40").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
         
Sheets(Range("AR1").Value).Select
    Range("AG43").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
         
Sheets(Range("AR1").Value).Select
    Range("AG46").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
         
Sheets(Range("AR1").Value).Select
    Range("AG49").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
                                                                              
Sheets(Range("AR1").Value).Select
    Range("G38").Select
    Selection.Copy
    Range("L1").Select
    Sheets("Spielabschnitt").Select
    Range("AI" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
     
  Application.CutCopyMode = False
   
End Sub

[Maximus]

Ich möchte noch einmal versuchen mein Problem allgemein darzustellen, vielleicht wird es dann verständlicher.

Ich möchte die Einträge aus ca. 15 Zellen eines Arbeitsblattes in EINE Zelle eines anderen Arbeitsblattes übertragen.
Es ist immer nur in einer der 15 Zellen einen Eintrag!
Durch das VBA-Programm lasse ich aber immer alle 15 Zellen übertragen, weil in welcher einen Zelle der 15 Zellen der Eintrag ist, ist unterschiedlich.
Wie kann ich das anstellen, dass trotz Übertrag der 15 Zellen in die eine Zelle auch der eine Eintrag übertragen übernommen wird und nicht wie ich zur Zeit das Problem habe, dass durch den Übertrag gar nichts in der einen Zelle steht.

Wenn ich durch das VBA Programm nur die eine einzige Zelle mit Inhalt übertragen lasse, funktioniert der Übertrag.
Nur wenn ich alle 15 Zellen übertragen lasse, obwohl wie gesagt nur in einer Zelle ein Eintrag ist, wird nichts übertragen.
Das VBA Programm überträgt auch den leeren Inhalt und somit wird nichts in der einen Zelle angezeigt.

[Maximus]

Besteht irgendie die Möglichkeit eines Zusatzes in jedem Teilprogramm,
DASS NUR EIN ÜBERTRAG STATTFINDEN SOLL, wenn auch ein tatsächlicher Eintrag in der Zelle vorhanden ist.

Inwieweit müsste man diesen Teil der Formel erweitern:

Sheets(Range("AR1").Value).Select
    Range("AG6").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues



ich würde den Zusatz auf die anderen Absätze übertragen und schauen, ob es geht.

[Steffl]

Hallo,

meinst Du so?

Code:

Sub kopieren()
    Dim rngZelle As Range
    
    Range("M1:M2").Copy

    Worksheets("Spielabschnitt").Range("AR1").PasteSpecial Paste:=xlPasteValues
    
    
    For Each rngZelle In Range("AG9,AG12,AG15,AG23,AG26,AG29,AG40,AG43,AG46,AG49")
    
        If rngZelle.Value <> "" Then
            rngZelle.Copy Worksheets("Spielabschnitt").Range("H" & Worksheets("Spielabschnitt").Range("AR2").Value)
            Exit For
        End If
    Next rngZelle
'
'Sheets(Range("AR1").Value).Select
'    Range("G38").Select
'    Selection.Copy
'    Range("L1").Select
'    Sheets("Spielabschnitt").Select
'    Range("AI" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
    
  Application.CutCopyMode = False
  
End Sub

[Maximus]

Danke Stefan,
habe dein Programm mal eingepflegt:
........
Sheets(Range("AR1").Value).Select
    Range("Q10").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("AO" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
    
    For Each rngZelle In Range("AG9,AG12,AG15,AG23,AG26,AG29,AG40,AG43,AG46,AG49")
    
        If rngZelle.Value <> "" Then
            rngZelle.Copy Worksheets("Spielabschnitt").Range("H" & Worksheets("Spielabschnitt").Range("AR2").Value)
            Exit For
        End If
    Next rngZelle
                                                                           
Sheets(Range("AR1").Value).Select
    Range("G38").Select
    Selection.Copy
    Range("L1").Select
    Sheets("Spielabschnitt").Select
    Range("AI" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues
     
  Application.CutCopyMode = False
   
End Sub


Macht trotzdem keinen Übertrag!

Gruss

[Maximus]

Wie kann ich das hinbekommen dass ich dieses Teilprogramm:

Sheets(Range("AR1").Value).Select
    Range("AG6").Select
    Selection.Copy
    Sheets("Spielabschnitt").Select
    Range("H" & Range("AR2").Value).PasteSpecial Paste:=xlPasteValues



dahingehend erweiter, dass ein Übertrag nur stattfindet wenn auch ein tatsächlicher Eintrag, in dem Falle in Zelle AG6.

Für die Erweiterung muss ich dazu sagen, dass jede AG Zelle noch einer anderen Zelle zugeordnet ist, dass eventuell in die Erweiterung einbezogen werden könnte:
Für AG6 existiert die Zelle AA6. Wenn in AA6 eine 0 steht, dann soll AG6 nach H NICHT übertragen werden.
Wenn in AA6 eine 1 steht, dann soll AG6 nach H übertragen werden.

Ob Null oder 1 dort steht habe ich mit einem Kontrollkästchen gelöst! Ist schön bei youtube unter Kontrollkästchen erklärt, wie man ein Kontrollkästchen einer falsch /wahr Zelle zuordnen kann. Diese falsch/wahr zelle kann man dann einer anderen zelle 0/1 zuordnen.


Für AG9 existiert AA9
usw.

[Steffl]

Hallo Markus,

durch deine total unnötige Selektierung von Tabellenblättern verweist meine Lösung auf das falsche (in dem Fall Spielabschnitt) Tabellenblatt. Hänge bei dem Range noch das Worksheet mit dem passenden Tabellennamen an dann sollte es funktiionieren.

Code:

For Each rngZelle In Worksheets(".....")Range("AG9,AG12,AG15,AG23,AG26,AG29,AG40,AG43,AG46,AG49")
    
        If rngZelle.Value <> "" Then
            rngZelle.Copy Worksheets("Spielabschnitt").Range("H" & Worksheets("Spielabschnitt").Range("AR2").Value)
            Exit For
        End If
    Next rngZelle

Die Punkte musst Du den richtigen Tabellennamen ersetzen!

[shift-del]

Maximus,

mir scheint dein ganzer Aufbau ziemlich chaotisch zu sein.
Wenn es um eine Zahl geht und keine weiteren Zahlen im Bereich AG6:AG49 stehen, dann geht es auch mit einer einfachen Formel:

Code:

=VERWEIS(9^99;Kopie1!$AG$6:$AG$49)

[Maximus]

Danke Stefan für deine Mühe.
Ich bekomme das so nicht hin.
Aus einem anderen Grund muß die Erweiterung, dass ein Übertrag nur wenn tatsächlicher Eintrag, sich auf die Zelle beziehen und nicht auf das Arbeitsblatt, weil ich zig Kopien erstellen werde  und dann müsste ich immer wieder den Namen des Arbeitsblattes verändern.

Wenn möglich, könntest du die Erweiterung nur auf AG6 erweitern.

Ich würde das dann auf alle anderen AG Zellen abändern.

Vielleicht hilt dieser Zusatz bei der Erstellung der Erweiterung dass jede AG Zelle noch einer anderen Zelle zugerdnet ist.
Für AG6 existiert die Zelle AA6. Wenn in AA6 eine 0 steht, dann soll AG6 nach H NICHT übertragen werden.
Wenn in AA6 eine 1 steht, dann soll AG6 nach H übertragen werden.

Danke und Gruss

[Maximus]

Maximus,

mir scheint dein ganzer Aufbau ziemlich chaotisch zu sein.
Wenn es um eine Zahl geht und keine weiteren Zahlen im Bereich AG6:AG49 stehen, dann geht es auch mit einer einfachen Formel:

Code:

=VERWEIS(9^99;Kopie1!$AG$6:$AG$49)

Hi shift, das geht nicht um ein Zahl.
Letzten Endes steht dort ein kleiner Text.
Der Übertrag funktioniert ja mit der bestehenden Formel!

Nur das Programm übertrat stumpf alle AG Zellen nach H2.
Irgenwie müßte das VBA Programm dahingehend geändert werden, dass nur dann der Übertrag erfolgen soll, wenn auch ein Text in den AG Zellen steht.

Eventuell hilft dabei, dass jede AG Zelle noch eine anderen Zelle zugeordnet ist. wie oben beschrieben.

Gruss