AW: meine Zeit für paar Stunden um (
01.03.2010 00:59:50
mehmet
Hallo Rainer,
nicht ganz elegant!
Zuviel Codes - aber es funktioniert 8)
Hier der Code:
Private Sub Create_Commaseparatet_String_Komma()
'by Ramses
'Verweis auf MS_Forms 2.0 DLL muss gesetzt sein wegen DataObject
'Erstellt aus gefilterten oder ungefilterten Zellen in einem Bereich einen
'fortlaufenden !!! Textstring
'mit definierten Trennzeichen und packt diesen in die Zwischenablage
Dim myDiv As String
Dim CopyObj As DataObject, expStr As String
Dim myC As Range, copyRng As Range
Set CopyObj = New DataObject
'Trennzeichen definieren
myDiv = ","
'Bereich "B" anpassen wo die Daten ausgelesen werden sollen
Set copyRng = Range("c5:c" & Rows.Count)
For Each myC In copyRng
If Rows(myC.Row).Hidden = False Then
expStr = expStr & myC.Text & myDiv
End If
If myC.Offset(1, 0) = "" Then Exit For
Next
expStr = Left(expStr, Len(expStr) - 1)
CopyObj.SetText expStr
CopyObj.PutInClipboard
Set CopyObj = Nothing
'Der String ist jetzt in der Zwischenablage und kann mit "Ctrl"+"v" überall eingefügt _
werden
End Sub
'Verweis auf "FM20.dll" (Microsoft Forms 2.0 Object Library)
Sub CommandButton1_Click()
Nachricht = "- JA - mit Komma" & Chr(13) & _
"- Nein - mit Semikon " & Chr(13) & _
Chr(13)
Stil = vbYesNo
Titel = "Trennung in Zwischenspeicher"
Antwort = MsgBox(Nachricht, Stil, Titel)
If Antwort = vbYes Then
Call Create_Commaseparatet_String_Komma
Else
Call Create_Commaseparatet_String_Semi
Exit Sub
End If
End Sub
Private Sub Create_Commaseparatet_String_Semi()
'by Ramses
'Verweis auf MS_Forms 2.0 DLL muss gesetzt sein wegen DataObject
'Erstellt aus gefilterten oder ungefilterten Zellen in einem Bereich einen
'fortlaufenden !!! Textstring
'mit definierten Trennzeichen und packt diesen in die Zwischenablage
Dim myDiv As String
Dim CopyObj As DataObject, expStr As String
Dim myC As Range, copyRng As Range
Set CopyObj = New DataObject
'Trennzeichen definieren
myDiv = ";"
'Bereich "B" anpassen wo die Daten ausgelesen werden sollen
Set copyRng = Range("c5:c" & Rows.Count)
For Each myC In copyRng
If Rows(myC.Row).Hidden = False Then
expStr = expStr & myC.Text & myDiv
End If
If myC.Offset(1, 0) = "" Then Exit For
Next
expStr = Left(expStr, Len(expStr) - 1)
CopyObj.SetText expStr
CopyObj.PutInClipboard
Set CopyObj = Nothing
'Der String ist jetzt in der Zwischenablage und kann mit "Ctrl"+"v" überall eingefügt _
werden
End Sub
Hier die Datei:
https://www.herber.de/bbs/user/68289.xls
Das geht bestimmt besser, was meinst Du ... 8)
Gruss
mehmet