Tabellenspalten vergleichen

Hallo zusammen,
habe zwar gesucht aber nichts gefunden.
Ich habe ca. 11 identische Blätter mit gleichem Inhalt jedoch alle Blätter heißen anders. Andere Blätter mit anderem Inhalt hat es auch noch.
Wenn ich in Tab1 im Bereich E1-P1 eine neue Überschrift zufüge sollte diese im aktiven Blatt (zBs. Tab2 ) beim Makrostart mit Tab1 verglichen und übernommen werden. Der Bereich in Tab2 soll dann automatisch um diese neuen Überschriften erweitert werden, d.h. die neuen Spalten müssen mit Formatierung eingefügt werden, andere Spalten nach rechts verschieben, nichts überschreiben.
https://www.herber.de/bbs/user/91913.xls
Ein Beispiel habe ich mit hochgeladen.
Mit freundlichen Grüßen
Manfred

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Spalten_einfügen() Dim ok, i As Integer On Error Resume Next For i = 1 To Worksheets.Count Sheets(i).Select If ActiveSheet.Name = "Tabelle1" Then GoTo weiter 'If ActiveSheet.Name = "unerwünscht" Then GoTo weiter ok = MsgBox("Spalten einfügen?", vbYesNoCancel) If ok = vbCancel Then Exit For If ok = vbYes Then Sheets("Tabelle1").Columns("E:P").Copy ActiveSheet.Columns("E:P").Insert Shift:=xlToRight End If weiter: Next i Sheets("Tabelle1").Select End Sub

Sub test() Dim Header As Range For Each Header In Tabelle1.Range("Überschriften") If Header.Text ActiveSheet.Cells(Header.Row, Header.Column).Text Then Header.EntireColumn.Copy ActiveSheet.Cells(Header.Row, Header.Column).Columns(1).Insert End If Next Header End Sub

Hallo Manfred,
Zuerst solltest du dich versichern, dass der benannte Bereich den Richtigen Bezug hat.
Nämlich


=Tab1!$E$5:$P$5

Und dann ist eine kleine Änderung im Code erforderlich.
Sollen weiterhin ganze Spalten eingefügt werden, sieht das so aus:

Sub test()
Dim Header As Range
For Each Header In Tabelle1.Range("Überschriften")
If Header.Text  ActiveSheet.Cells(Header.Row, Header.Column).Text Then
Header.EntireColumn.Copy
ActiveSheet.Cells(1, Header.Column).Columns(1).Insert
End If
Next Header
End Sub

Soll nur die Spalte ab Zeile 5 Kopiert werden, muss man da nochmal dran schrauben :)
Viele Grüße
Robert

Sub test() Dim Header As Range For Each Header In Tabelle1.Range("Überschriften") If Header.Text ActiveSheet.Cells(Header.Row, Header.Column).Text Then Tabelle1.Range(Header.Address, Tabelle1.Cells(Tabelle1.UsedRange.SpecialCells( _ xlCellTypeLastCell).Row, Header.Column)).Copy ActiveSheet.Cells(Header.Row, Header.Column).Columns(1).Insert End If Next Header End Sub

Das war die hier: Sub test() Dim Header As Range For Each Header In Tabelle1.Range("Überschriften") If Header.Text ActiveSheet.Cells(Header.Row, Header.Column).Text Then Header.EntireColumn.Copy ActiveSheet.Cells(1, Header.Column).Columns(1).Insert End If Next Header End Sub

Beliebteste Forumthreads (12 Monate)

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread