[color=green]'Deklarationen für die Funktion "TextAusZwischenablage"
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (lpString1 As Any, _
  lpString2 As Any) As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As _
  Any) As Long
 
Function TextAusZwischenablage() As String
[color=green]'siehe Workshop "DIE ZWISCHENABLAGE IM GRIFF" von LonelySuicide
'http://www.vbarchiv.net/workshop/workshop23.php
Dim Tmpstr As String
Dim pTmpStr As Long
Dim hTmpStr As Long
 
[color=green]'!!! Me.hwnd durch (Excel.)Application.hwnd ersetzen !!!
OpenClipboard Application.hwnd
hTmpStr = GetClipboardData(1)
pTmpStr = GlobalLock(hTmpStr)
If pTmpStr <> 0 Then
 Tmpstr = Space(lstrlen(ByVal pTmpStr))
 Call lstrcpy(ByVal Tmpstr, ByVal pTmpStr)
 GlobalUnlock hTmpStr
End If
CloseClipboard
 
TextAusZwischenablage = Tmpstr
End Function
 
[color=green]'Das bestehende Beispiel um ein paar Zeilen ergänzt
Sub BeispielDeLuxe()
Dim iZelle1 As Integer
Dim iZelle2 As Integer
Dim sSuche1 As String
Dim sSuche2 As String
Dim lRet As Long
Dim iSuche As Integer
Dim sText As String
 
sText = TextAusZwischenablage
 
For iSuche = 1 To 2
 If sText <> "" Then
    lRet = MsgBox("In der Zwischenablage befindet " & _
            "sich folgender Text:" & _
            vbCr & vbCr & "A" & vbCr & vbCr & _
            "Soll dieser Text als " & iSuche & _
            ". Suchbegriff übernommen werden?", _
            vbYesNoCancel + vbQuestion, "Frage")
    Select Case lRet
     Case vbYes
        If iSuche = 1 Then sSuche1 = sText: sText = ""
        If iSuche = 2 Then sSuche2 = sText
     Case vbNo
      If iSuche = 1 Then _
            sSuche1 = InputBox(iSuche & ". Suchwort:")
      If iSuche = 2 Then _
            sSuche2 = InputBox(iSuche & ". Suchwort:")
     Case vbCancel
        Exit Sub
    End Select
 Else
    Select Case iSuche
     Case 1
        If sSuche1 = "" Then _
            sSuche1 = InputBox(iSuche & ". Suchwort:")
     Case 2
        If sSuche2 = "" Then _
            sSuche2 = InputBox(iSuche & ". Suchwort:")
    End Select
 End If
Next iSuche
 
Range("a1").Select
iZelle1 = Cells.Find(What:=sSuche1, After:=ActiveCell, LookIn:=xlValues, _
  LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False _
        , SearchFormat:=False).Column
 
iZelle2 = Cells.Find(What:=sSuche2, After:=ActiveCell, LookIn:=xlValues, _
  LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False _
        , SearchFormat:=False).Column
 
If iZelle1 < iZelle2 Then
Range(Cells.Columns(iZelle1), Cells.Columns(iZelle2)).Copy
ElseIf iZelle1 > iZelle2 Then
Range(Cells.Columns(iZelle2), Cells.Columns(iZelle1)).Copy
End If
 
Workbooks.Open "C:\Neu.xls"
Workbooks("Neu.xls").Sheets("Tabelle2").Select
ActiveSheet.Paste
End Sub