Microsoft Excel

Herbers Excel/VBA-Archiv

Format in 2.Reiter kopieren

Betrifft: Format in 2.Reiter kopieren von: Nik
Geschrieben am: 08.08.2014 10:37:14

Hi,

Kann mir jemand helfen das Format der Spalten BB bis BK in einen2.Reiter zu kopieren?
Immer wenn eine Zeile angeklickt wird, soll das Format in den Spalten in dieser Zeile übernommen werden...

Mein Code momentan sieht so aus:
Für die "Kreuze" der 1.Code

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  
    Dim RaBereich As Range
    
    Set RaBereich = Range("BB2:BK1000000")

    If Not Intersect(Target, RaBereich) Is Nothing Then
       
        If Target.Borders(xlDiagonalDown).LineStyle = 1 Then
            With Target
                
                .Borders(xlDiagonalDown).LineStyle = xlNone
               
                .Borders(xlDiagonalUp).LineStyle = xlNone
            End With
        Else
           
            With Target
                
                .Borders(xlDiagonalDown).LineStyle = xlContinuous
              
                .Borders(xlDiagonalDown).Weight = xlThick
                
                .Borders(xlDiagonalUp).LineStyle = xlContinuous
               
                .Borders(xlDiagonalUp).Weight = xlThick
            End With
        End If
       
        Cancel = True
    End If
    Set RaBereich = Nothing
    
                          
End Sub
Für die Zuteilung zum w. Reiter dieser Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws2 As Worksheet
Dim aktZeile As Long

Set ws2 = ThisWorkbook.Worksheets("Messauftrag")
If Target.Rows.Count > 1 Then Exit Sub
aktZeile = Target.Row
ws2.Range("B5") = Me.Cells(aktZeile, "B")
ws2.Range("B6") = Me.Cells(aktZeile, "C")
ws2.Range("B7") = Me.Cells(aktZeile, "F")
ws2.Range("B8") = Me.Cells(aktZeile, "G")
ws2.Range("B9") = Me.Cells(aktZeile, "AP")
ws2.Range("B10") = Me.Cells(aktZeile, "K")
ws2.Range("B11") = Me.Cells(aktZeile, "AM")
ws2.Range("E5") = Me.Cells(aktZeile, "I")
ws2.Range("E6") = Me.Cells(aktZeile, "J")
ws2.Range("E7") = Me.Cells(aktZeile, "BM")
ws2.Range("E8") = Me.Cells(aktZeile, "BN")
ws2.Range("E9") = Me.Cells(aktZeile, "BO")
ws2.Range("B16") = Me.Cells(aktZeile, "AQ")
ws2.Range("B17") = Me.Cells(aktZeile, "N")
ws2.Range("B18") = Me.Cells(aktZeile, "AN")
ws2.Range("B19") = Me.Cells(aktZeile, "AF")
ws2.Range("B20") = Me.Cells(aktZeile, "AJ")
ws2.Range("B21") = Me.Cells(aktZeile, "AC")
ws2.Range("B22") = Me.Cells(aktZeile, "AG")
ws2.Range("B23") = Me.Cells(aktZeile, "AB")
ws2.Range("B24") = Me.Cells(aktZeile, "AD")
ws2.Range("B25") = Me.Cells(aktZeile, "AE")
ws2.Range("B26") = Me.Cells(aktZeile, "AI")
ws2.Range("B27") = Me.Cells(aktZeile, "R")
ws2.Range("E16") = Me.Cells(aktZeile, "S")
ws2.Range("E17") = Me.Cells(aktZeile, "T")
ws2.Range("E18") = Me.Cells(aktZeile, "U")
ws2.Range("E19") = Me.Cells(aktZeile, "W")
ws2.Range("E20") = Me.Cells(aktZeile, "Y")
ws2.Range("E21") = Me.Cells(aktZeile, "V")
ws2.Range("E22") = Me.Cells(aktZeile, "X")
ws2.Range("E23") = Me.Cells(aktZeile, "Z")
ws2.Range("E24") = Me.Cells(aktZeile, "AA")
ws2.Range("B32") = Me.Cells(aktZeile, "BB")
ws2.Range("B33") = Me.Cells(aktZeile, "BC")
ws2.Range("B34") = Me.Cells(aktZeile, "BD")
ws2.Range("B35") = Me.Cells(aktZeile, "BE")
ws2.Range("B36") = Me.Cells(aktZeile, "BF")
ws2.Range("B37") = Me.Cells(aktZeile, "BG")
ws2.Range("B38") = Me.Cells(aktZeile, "BH")
ws2.Range("B39") = Me.Cells(aktZeile, "BI")
ws2.Range("B40") = Me.Cells(aktZeile, "BJ")
ws2.Range("B41") = Me.Cells(aktZeile, "BK")
ws2.Range("E32") = Me.Cells(aktZeile, "AR")
ws2.Range("E33") = Me.Cells(aktZeile, "AS")
ws2.Range("E34") = Me.Cells(aktZeile, "AT")
ws2.Range("E35") = Me.Cells(aktZeile, "AU")
ws2.Range("E36") = Me.Cells(aktZeile, "AV")
ws2.Range("E37") = Me.Cells(aktZeile, "AW")
ws2.Range("E38") = Me.Cells(aktZeile, "AX")
ws2.Range("E39") = Me.Cells(aktZeile, "AY")
ws2.Range("E40") = Me.Cells(aktZeile, "AZ")
ws2.Range("E41") = Me.Cells(aktZeile, "BA")
End Sub

Jetzt wird momentan aber der Inhalt der Spalten BB bis BK kopiert und nicht das Format
Danke schon mal..

  

Betrifft: AW: Format in 2.Reiter kopieren von: Dieter Klemke
Geschrieben am: 08.08.2014 15:17:59

Hallo Nik,

ist jetzt aus Alexa Nik geworden?
Das Umkopieren der Formate würde ich so machen:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim ws2 As Worksheet
  
  Set ws2 = ThisWorkbook.Worksheets("Tabelle2")
  If Target.Rows.Count > 1 Then Exit Sub
  aktZeile = Target.Row
  If (aktZeile <> aktZeileOld) Then
  Format_übertragen Me.Cells(aktZeile, "B"), ws2.Range("B5")
  Format_übertragen Me.Cells(aktZeile, "C"), ws2.Range("B6")
  '...
 End If
End Sub

Sub Format_übertragen(rngQuelle As Range, _
                      rngZiel As Range)
  rngQuelle.Copy
  rngZiel.PasteSpecial Paste:=xlPasteFormats
  Application.CutCopyMode = xlCut
End Sub
Viele Grüße
Dieter


  

Betrifft: AW: Format in 2.Reiter kopieren von: fcs
Geschrieben am: 08.08.2014 16:10:31

Hallo Nik,

um die Formate ins 2. Blatt zu übertragen muss man die Zellen kopieen und per PasteSpecial nur die Formate einfügen.

Dazu kann man das Makro wie folgt anpassen.
Damit die Kopieraktion nicht bei jeder zellselektion anläuft hab ich noch eine 2. Prüfung eingebaut.

Gruß
Franz

'Für die Zuteilung zum w. Reiter dieser Code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws2 As Worksheet
Dim aktZeile As Long
Dim lngSpalte As Long, strSpalte As String, strZelle As String

Set ws2 = ThisWorkbook.Worksheets("Messauftrag")

If Target.Rows.Count > 1 Then Exit Sub
If Target.Column <> 1 Then Exit Sub
'Kopiert wird, wenn man in Zelle in Spalte A klickt oder auf die Nummer der Zeile (ganze Zeile  _
wird markiert.
aktZeile = Target.Row
Application.ScreenUpdating = False
For lngSpalte = 1 To 70 'A bis BR
  strSpalte = Me.Cells(1, lngSpalte).Address(False, False, xlA1)
  strSpalte = Left(strSpalte, Len(strSpalte) - 1)
  Select Case strSpalte
    Case "B": strZelle = "B5"
    Case "C": strZelle = "B6"
    Case "F": strZelle = "B7"
    Case "G": strZelle = "B8"
    Case "AP": strZelle = "B9"
    Case "K": strZelle = "B10"
    Case "AM": strZelle = "B11"
    Case "I": strZelle = "E5"
    Case "J": strZelle = "E6"
    Case "BM": strZelle = "E7"
    Case "BN": strZelle = "E8"
    Case "BO": strZelle = "E9"
    Case "AQ": strZelle = "B16"
    Case "N": strZelle = "B17"
    Case "AN": strZelle = "B18"
    Case "AF": strZelle = "B19"
    Case "AJ": strZelle = "B20"
    Case "AC": strZelle = "B21"
    Case "AG": strZelle = "B22"
    Case "AB": strZelle = "B23"
    Case "AD": strZelle = "B24"
    Case "AE": strZelle = "B25"
    Case "AI": strZelle = "B26"
    Case "R": strZelle = "B27"
    Case "S": strZelle = "E16"
    Case "T": strZelle = "E17"
    Case "U": strZelle = "E18"
    Case "W": strZelle = "E19"
    Case "Y": strZelle = "E20"
    Case "V": strZelle = "E21"
    Case "X": strZelle = "E22"
    Case "Z": strZelle = "E23"
    Case "AA": strZelle = "E24"
    Case "BB": strZelle = "B32"
    Case "BC": strZelle = "B33"
    Case "BD": strZelle = "B34"
    Case "BE": strZelle = "B35"
    Case "BF": strZelle = "B36"
    Case "BG": strZelle = "B37"
    Case "BH": strZelle = "B38"
    Case "BI": strZelle = "B39"
    Case "BJ": strZelle = "B40"
    Case "BK": strZelle = "B41"
    Case "AR": strZelle = "E32"
    Case "AS": strZelle = "E33"
    Case "AT": strZelle = "E34"
    Case "AU": strZelle = "E35"
    Case "AV": strZelle = "E36"
    Case "AW": strZelle = "E37"
    Case "AX": strZelle = "E38"
    Case "AY": strZelle = "E39"
    Case "AZ": strZelle = "E40"
    Case "BA": strZelle = "E41"
  Case Else
    strZelle = ""
  End Select
  If strZelle <> "" Then
    Me.Cells(aktZeile, lngSpalte).Copy
    ws2.Range(strZelle).PasteSpecial Paste:=xlPasteFormats 'Format kopieren
    ws2.Range(strZelle) = Me.Cells(aktZeile, lngSpalte) 'Wert übertragen
  End If
Next
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub



 

Beiträge aus den Excel-Beispielen zum Thema "Format in 2.Reiter kopieren"