Für Euch nur eine Kleinigkeit :-)

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Michael,
der Code gehört in ein normales Modul. Wenn du das Makro "Texte_länger_5_in_Zwischenablage"
startest, wird die Zwischenablage gefüllt:


Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" ( _
ByVal wFormat As Long, _
ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" ( _
ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" ( _
ByVal lpStr1 As Any, _
ByVal lpStr2 As Any) As Long
Private Const GMEM_MOVEABLE As Long = 2&
Private Const CF_TEXT As Long = 1&
Sub Texte_länger_5_in_Zwischenablage()
Const strTrenn As String = " "             ' oder z. B. vbCrLf
Dim rngC As Range, strSamm As String
For Each rngC In Range("A3:G1000")
If Len(rngC) > 5 Then strSamm = strSamm & rngC & strTrenn
Next rngC
If strSamm > "" Then _
StringToClipboard Left(strSamm, Len(strSamm) - Len(strTrenn))
End Sub
Private Sub StringToClipboard(s As String)
'  von Risi Thomas Softwareentwicklung   www.rtsoftwaredevelopment.de
Dim hMem As Long, hPtr As Long
hMem = GlobalAlloc(GMEM_MOVEABLE, Len(s) + 1)
hPtr = GlobalLock(hMem)
lstrcpy hPtr, s
GlobalUnlock hMem
OpenClipboard 0&
EmptyClipboard
SetClipboardData CF_TEXT, hMem
CloseClipboard
GlobalFree hMem
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Hallo Michael,
probier diesen Code.
Sub Texte_länger_5_in_Zwischenablage()
Dim vVal As Variant, vTmp() As String, vH() As String
Dim lngR As Long, lngI As Long
Dim intC As Integer, intI As Integer

vVal = Range("A3:G1000")

For lngR = 1 To UBound(vVal, 1)
    For intC = 1 To UBound(vVal, 2)
        If Len(vVal(lngR, intC)) > 5 Then
            If InStr(1, vVal(lngR, intC), " ") > 0 Then
                vH = Split(vVal(lngR, intC), " ")
                For intI = 0 To UBound(vH)
                    If Len(vH(intI)) > 5 Then
                        Redim Preserve vTmp(lngI)
                        vTmp(lngI) = vH(intI)
                        lngI = lngI + 1
                    End If
                Next
            Else
                Redim Preserve vTmp(lngI)
                vTmp(lngI) = vVal(lngR, intC)
                lngI = lngI + 1
            End If
        End If
    Next
Next

If lngI > 0 Then StringToClipboard Join(vTmp, " ")

End Sub

Gruß Sepp

Sub Texte_länger_5_in_Zwischenablage() Const strTrenn As String = " " ' oder z. B. vbCrLf Dim rngC As Range, strW As String, arrS, ii As Integer, strSamm As String For Each rngC In Range("A3:G1000") If Len(rngC) > 5 Then strW = Replace(rngC, " ", ",") strW = Replace(strW, ".", ",") strW = Replace(strW, "-", ",") strW = Replace(strW, "/", ",") strW = Replace(strW, vbCrLf, ",") strW = Replace(strW, vbLf, ",") strW = Replace(strW, vbCr, ",") arrS = Split(strW, ",") For ii = 0 To UBound(arrS) If Len(arrS(ii)) > 5 Then strSamm = strSamm & arrS(ii) & strTrenn Next ii End If Next rngC If strSamm > "" Then StringToClipboard Left(strSamm, Len(strSamm) - Len(strTrenn)) End Sub

Beliebteste Forumthreads (12 Monate)

Für Euch nur eine Kleinigkeit :-)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread