AW: Spalten zusammenführen; vorher Spaltenauswahl
02.02.2006 12:41:01
Heiko
Hallo Erwin,
ja is den heut schon Weihnachten ?!
so gehts ;-)
Sub SpaltenZusammenfuehren2()
Dim bytAnzahlSpalten As Byte, bytHelp As Byte
Dim lngHelp As Long
Dim strhelp As String, strSpalten As String
Dim arrSpalten As Variant
strSpalten = InputBox("Welche Spalten sollen zusammengeführt werden ! " & vbCr & vbCr & _
"Angabe ohne Leerzeichen aber mit Komma !" & vbCr & _
vbCr & "Z.B A,B,C oder F,I,AA !", _
" Spaltenangabe ", "A,B,C")
If strSpalten = "" Or strSpalten = "Falsch" Then Exit Sub
arrSpalten = Split(strSpalten, ",")
bytAnzahlSpalten = UBound(arrSpalten) + 1
If Range(arrSpalten(UBound(arrSpalten)) & "1").Offset(0, 1) <> "" Then
If MsgBox("Die Spalte neben '" & arrSpalten(UBound(arrSpalten)) & _
"' ist nicht leer ! Soll eine neue eingefügt werden = JA, Makro beenden = NEIN ", _
vbYesNo + vbCritical) = vbYes Then
ActiveSheet.Range(arrSpalten(UBound(arrSpalten)) & "1").Offset(0, 1).EntireColumn.Insert Shift:=xlToRight
Else
Exit Sub
End If
End If
With ActiveSheet
For lngHelp = 1 To .UsedRange.Rows.Count
strhelp = ""
For bytHelp = 1 To bytAnzahlSpalten
strhelp = strhelp & .Range(arrSpalten(bytHelp - 1) & lngHelp)
Next bytHelp
.Range(arrSpalten(UBound(arrSpalten)) & lngHelp).Offset(0, 1) = strhelp
Next lngHelp
End With
End Sub
Gruß Heiko
PS: Rückmeldung wäre nett !