Inhalt immer in neue Spalte einfügen

Question

Hab hier ein Makro gefunden das mir die Spalten nach Inhalt durchsucht und dann immer in nächste freie Spalte kopiert.
Aber irgendwie funktioniert das nicht wie es soll.
Es fehlen immer einige Inhalte außerdem wäre es nicht schlecht wenn es die Werte nicht in ein neues Tabellenblatt kopiert sondern
im Tabellenblatt bleibt also alles was gefunden wird nur in eine neue Spalte einfügt.
Vielleicht kann mir das jemand zurechtbiegen

Sub spalten()

Dim lngSpalten As Long
Dim arrInhalt As Variant
Dim lngZielspalte As Long
Dim lngZielzeile As Long
Dim wksQuelle As Worksheet
Dim wksZiel As Worksheet
Dim lngZaehler As Long
Dim bZahl As Boolean

'Quell- und Zieltabelle definieren - Namen anpassen
Set wksQuelle = ThisWorkbook.Worksheets("Tabelle1")
Set wksZiel = ThisWorkbook.Worksheets("Tabelle2")

'ggf. vorhandene Inhalte in Zieltabelle löschen
wksZiel.Cells.Clear

'Schleife für Spalten; Anzahl der Spalten wird in Zeile 1 festgestellt
For lngSpalten = 1 To wksQuelle.Cells(1, Columns.Count).End(xlToLeft).Column
'Marker wird auf falsch gesetzt
bZahl = False
'Spalte wird in Array eingelesen
With wksQuelle
arrInhalt = .Range(.Cells(1, lngSpalten), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, lngSpalten))
End With
'eingelesenes Array durchlaufen
For lngZaehler = LBound(arrInhalt) To UBound(arrInhalt)
'prüfen, ob Inhalt Zahl ist
If IsEmpty(arrInhalt(lngZaehler, 1)) = False Then
If bZahl = False Then
bZahl = True 'Marker auf wahr setzen
lngZielspalte = lngZielspalte + 1 'Variable für Zielspalte um 1 erhöhen
lngZielzeile = 0
End If

'Zahl in neues Blatt übertragen, falls Inhalt eine Zahl ist
If bZahl = True Then
lngZielzeile = lngZielzeile + 1
wksZiel.Cells(lngZielzeile, lngZielspalte) = arrInhalt(lngZaehler, 1)
End If
Else
bZahl = False 'ansonsten wird der Marker auf falsch gesetzt
End If

Next lngZaehler

Next lngSpalten

End Sub

Answer 1

Hallo,

versuch mal den folgenden Code:

Sub spalten()

Dim lngSpalten As Long
Dim arrInhalt As Variant
Dim lngZielspalte As Long
Dim lngZielzeile As Long
Dim lngZaehler As Long
Dim lngLSpalte As Long

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'letzte Spalte in Zeile 1 ermitteln
lngLSpalte = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

'Schleife für Spalten; Anzahl der Spalten wird in Zeile 1 festgestellt
For lngSpalten = 1 To lngLSpalte
'Spalte wird in Array eingelesen
With ActiveSheet
arrInhalt = .Range(.Cells(1, lngSpalten), .Cells(.Cells(Rows.Count, lngSpalten).End(xlUp).Row, lngSpalten))
End With
'Zähler für Zielzeile auf Null setzen
lngZielzeile = 0

'Zielspalte festlegen
lngZielspalte = lngLSpalte + lngSpalten + 2

'eingelesenes Array durchlaufen
For lngZaehler = LBound(arrInhalt) To UBound(arrInhalt)
'prüfen, ob Inhalt leer ist
If IsEmpty(arrInhalt(lngZaehler, 1)) = False Then
'falls nicht, dann Inhalt in Zielspalte übertragen
'Zähler für Einfügezeile erhöhen
lngZielzeile = lngZielzeile + 1
ActiveSheet.Cells(lngZielzeile, lngZielspalte) = arrInhalt(lngZaehler, 1)
End If
Next lngZaehler

Next lngSpalten

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Es fehlen immer einige Inhalte

Das liegt daran, dass in deinem Code immer die letzte Zeile in Spalte A ermittelt wird, um die Inhalte einer Spalte einzulesen:

arrInhalt = .Range(.Cells(1, lngSpalten), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, lngSpalten))

In diesem Teil ist der Fehler:
.Cells(.Cells(Rows.Count, 1).End(xlUp).Row
Sind in einigen Spalten mehr Daten als in Spalte A vorhanden, werden diese zusätzlichen Daten nicht eingelesen und somit ignoriert.

Gruß

M.O.

Answer 2

Hi M.O

dein Makro geht nicht er schreibt Typen unverträglich
For lngZaehler = LBound(arrInhalt) To UBound(arrInhalt) ist gelb im Debug Modus
Vielleicht habe ich mich auch falsch ausgedrückt.
Ist Zustand

Zahl
Zahl
Zahl
leer
leer
leer
Zahl
Zahl
leer
leer
leer
Zahl

Alles was nach den Leerzeilen steht in nächste Freie Spalte verschieben

Answer 3

hi Drobny :-)

Wie wäre es mit Spalten Überschriften .-)

Dann klappt es auch mit dem Makro ^^

Gruss Nighty

Answer 4

Hallo,

bei meinen Test funktioniert das Makro ohne Probleme mit Zahlen und auch mit Zahlen und Buchstaben. Kann es sein, dass du leere Spalten hast? Dann kommt nämlich der Fehler.

Probier mal den folgenden Code:

Sub spalten()

Dim lngSpalten As Long
Dim arrInhalt As Variant
Dim lngZielspalte As Long
Dim lngZielzeile As Long
Dim lngZaehler As Long
Dim lngLSpalte As Long

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'letzte Spalte in Zeile 1 ermitteln
lngLSpalte = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

'Schleife für Spalten; Anzahl der Spalten wird in Zeile 1 festgestellt
For lngSpalten = 1 To lngLSpalte
'Prüfen, ob in Spalte Werte stehen
If Application.WorksheetFunction.CountA(Columns(lngSpalten)) > 0 Then

'falls ja, dann Spalte in Array einlesen
With ActiveSheet
arrInhalt = .Range(.Cells(1, lngSpalten), .Cells(.Cells(Rows.Count, lngSpalten).End(xlUp).Row, lngSpalten))
End With
'Zähler für Zielzeile auf Null setzen
lngZielzeile = 0

'Zielspalte festlegen
lngZielspalte = lngLSpalte + lngSpalten + 2

'eingelesenes Array durchlaufen
For lngZaehler = LBound(arrInhalt) To UBound(arrInhalt)
'prüfen, ob Inhalt leer ist
If IsEmpty(arrInhalt(lngZaehler, 1)) = False Then
'falls nicht, dann Inhalt in Zielspalte übertragen
'Zähler für Einfügezeile erhöhen
lngZielzeile = lngZielzeile + 1
ActiveSheet.Cells(lngZielzeile, lngZielspalte) = arrInhalt(lngZaehler, 1)
End If
Next lngZaehler
End If
Next lngSpalten

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Oder schreibst wie, von Nighty vorgeschlagen, Überschriften in die erste Zeile, dann steht in den Spalten auf jeden Fall etwas drin ;-).

Gruß

M.O.

Answer 5

Edit:

Oder schreibst wie,

soll natürlich heißen: Oder du schreibst wie,

Gruß

M.O.