Microsoft Excel

Herbers Excel/VBA-Archiv

gleiche Spaltenüberschriften kopieren

Betrifft: gleiche Spaltenüberschriften kopieren von: Constantin
Geschrieben am: 20.11.2012 16:41:04

Hallo,

nach vielen Versuchen mit hin- und herkopieren möchte ich gerne ein Programm (aus dem Forum)verwenden, das mir die Spalteninhalte bei gleichen Überschriften von Tabelle1 nach Tabelle2 kopiert.

Wer kann mir helfen, nachstehendes Programm so anzupassen, dass ich die Zeilennummer der Quellüberschriften (Tabelle1) mit einer Variable festlegen kann und ebenso die Zeile, in der die Zielüberschriften stehen?
Beispiel: In Tabelle1 stehen die Überschriften in Zeile6 (ab Spalte 2) und in Tabelle2 in Zeile3.
Es sollen dann alle Spalteninhalte mit gleichen Überschriften übertragen werden. Das Programm möchte dann ich mit einem Commandbutton aufrufen.

Sub Spalten_übertragen()
Dim SpalteZiel As Integer, SpalteQuelle As Integer, rngSpalte As Range
Dim WsQuelle As Worksheet, wsZiel As Worksheet

'Tabellenblätter anpassen!
    
   Set WsQuelle = Tabelle1
   Set wsZiel = Tabelle2

'Schleife über alle Spalten der Quelle
   For SpalteQuelle = 1 To WsQuelle.UsedRange.Columns.Count + WsQuelle.UsedRange.Column - 1
      
      'Spalte im WsZiel suchen
      Set rngSpalte = wsZiel.Rows(1).Find(WsQuelle.Cells(1, SpalteQuelle).Value, lookat:= _
xlWhole, LookIn:=xlValues)
      
      'was gefunden`?
      If Not rngSpalte Is Nothing Then
          
         'Spaltennummer auslesen
         SpalteZiel = rngSpalte.Column
          
         'jetzt kannst du alles machen. z.B:
         Intersect(WsQuelle.Columns(SpalteQuelle), WsQuelle.UsedRange).Copy Destination:=wsZiel. _
Cells(1, SpalteZiel)
      
      End If
   Next

End Sub
Im Voraus vielen Dank für eure Unterstützung.

Grüße, Constantin

  

Betrifft: AW: gleiche Spaltenüberschriften kopieren von: fcs
Geschrieben am: 21.11.2012 06:53:30

Hallo Constantin,

nachfolgend dein Makro entsprechend angepasst.
Wie du die Zuweisung von Zieltabelle und Quelltabelle machen muss das hängt davon ab wo du das Makro speicherst.

Speicherst du es in der Datei, in der die beiden Tabellenblätter vorhanden sind, dann kannst du die Codenamen verwenden.

Speicherst du es in deiner persönlichen Makroarbeitsmappe, dann muss mit der Indexnummer der Blätter oder den Blattnamen arbeiten.

Gruß
Franz

Sub Spalten_übertragen()
  Dim SpalteZiel As Integer, SpalteQuelle As Integer, rngSpalte As Range
  Dim ZeileQuelle As Long, ZeileZiel As Long, ZeileQuelleL As Long
  Dim WsQuelle As Worksheet, wsZiel As Worksheet
  
  'Zeilen mit den Spaltentiteln
     ZeileQuelle = 6
     ZeileZiel = 2
     
  'Tabellenblätter anpassen!
     Set WsQuelle = ActiveWorkbook.Worksheets(1) 'Tabelle1 '
     Set wsZiel = ActiveWorkbook.Worksheets(2)  'Tabelle2 '
  
  'Schleife über alle Spalten der Quelle
  For SpalteQuelle = 1 To WsQuelle.UsedRange.Columns.Count + WsQuelle.UsedRange.Column - 1
     
     'Spalte im WsZiel suchen
     Set rngSpalte = wsZiel.Rows(ZeileZiel).Find(WsQuelle.Cells(ZeileQuelle, _
         SpalteQuelle).Value, lookat:=xlWhole, LookIn:=xlValues)
     
     'was gefunden`?
     If Not rngSpalte Is Nothing Then
         
        'Spaltennummer auslesen
        SpalteZiel = rngSpalte.Column
         
        'jetzt kannst du alles machen. z.B:
        With WsQuelle
           ZeileQuelleL = .Cells(.Rows.Count, SpalteQuelle).End(xlUp).Row
           If ZeileQuelleL > ZeileQuelle Then
             .Range(.Cells(ZeileQuelle + 1, SpalteQuelle), .Cells(ZeileQuelleL, _
               SpalteQuelle)).Copy
             With wsZiel.Cells(ZeileZiel + 1, SpalteZiel)
               .PasteSpecial Paste:=xlPasteFormats
               .PasteSpecial Paste:=xlPasteValues
             End With
             Application.CutCopyMode = False
           End If
        End With
     End If
  Next
End Sub



  

Betrifft: AW: perfekt! von: Constantin
Geschrieben am: 21.11.2012 07:50:59

Hallo Franz,

es läuft - vielen Dank für die super Unterstützung!

Grüße, Constantin


 

Beiträge aus den Excel-Beispielen zum Thema "gleiche Spaltenüberschriften kopieren"