Office: Spaltenabfrage - flexibles Makro

Hallo an alle Makro Experten,

ich habe folgendes Makro, dass sich momentan jedoch immer auf Spalte "C" bezieht. Wie bekomme ich es hin Spalte C als festen Wert durch eine Art Abfrage zu ersetzen bei dem ich die Spalte angeben kann und daraufhin das Makro ausgeführt wird. Also ein wenig flexibler gestalten, falls in manchen Tabellenblättern die gewünschte Aktion nicht in Spalte C, sondern in einer anderen oder mehreren durchgeführt werden soll?
vielen Dank im voraus
liebe grüße
MagB

Columns("C:C").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("C:C").Select
Selection.Copy
Columns("D:D").Select
Selection.Insert Shift:=xlToRight
Application.CutCopyMode = False
Range("D2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Sheet2!C[-3]:C[-2],2,0)"
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("D:D").Select
Selection.Copy
Columns("C:C").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("D:D").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Cells.Select
Range("A1:O139").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Range("E3").Select
End Sub

 

Hi,

versuche es mal auf diesem Weg:

Code:

Sub Spalten()
    Dim varSpalte As Variant
    Dim intSpalte As Integer
    varSpalte = Application.InputBox("Bitte Spalte eingeben", "Spalte", "C", Type:=2)
    On Error Resume Next
    intSpalte = Columns(varSpalte).Column
    On Error GoTo 0
    If intSpalte = 0 Then
        MsgBox "Das ist keine gültige Spaltenbezeichnung"
        Exit Sub
    End If
    Columns(varSpalte & ":" & varSpalte).TextToColumns Destination:=Range(varSpalte & 1), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    Columns(varSpalte & ":" & varSpalte).Copy
    Columns(varSpalte & ":" & varSpalte).Offset(, 1).Insert Shift:=xlToRight
    Cells(2, intSpalte + 1).FormulaR1C1 = "=VLOOKUP(RC[-1],Sheet2!C[-3]:C[-2],2,0)"
    Cells(2, intSpalte + 1).AutoFill Destination:=Range(Cells(2, intSpalte + 1), Cells(IIf(IsEmpty(Cells(Rows.Count, 3)), Cells(Rows.Count, 3).End(xlUp).Row, Rows.Count), intSpalte + 1))
    Columns(varSpalte & ":" & varSpalte).Offset(, 1).Copy
    Columns(varSpalte & ":" & varSpalte).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns(varSpalte & ":" & varSpalte).Offset(, 1).Delete Shift:=xlToLeft
    Range("A1:O139").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
End Sub

Bis später,
Karin

 

Die Abfrage funktioniert aber wenn ich NICHT Spalte C eingebe, sondern eine andere, dann gibt mir der SVERWEIS nur noch #NV aus.
könntest du nochmal reinschauen?

vielen dank
lg
magb

 

Hi,

ändere diese Zeile:

Code:

 
   Cells(2, intSpalte + 1).AutoFill Destination:=Range(Cells(2, intSpalte + 1), Cells(IIf(IsEmpty(Cells(Rows.Count, 3)), Cells(Rows.Count, 3).End(xlUp).Row, Rows.Count), intSpalte + 1)) 

in diese:

Code:

    Cells(2, intSpalte + 1).AutoFill Destination:=Range(Cells(2, intSpalte + 1), _
        Cells(IIf(IsEmpty(Cells(Rows.Count, intSpalte)), _
        Cells(Rows.Count, intSpalte).End(xlUp).Row, Rows.Count), intSpalte + 1))

Dort stand noch der Zellbezug zur Spalte C (3) drin.

Bis später,
Karin