Thema Datum  Von Nutzer Rating
Antwort
18.10.2017 08:38:48 Chris
NotSolved
18.10.2017 09:33:53 Chris
NotSolved
18.10.2017 12:12:35 Gast31549
NotSolved
Blau Abgeschlossen...Code jetzt richtig...
18.10.2017 12:19:03 Gast14221
NotSolved

Ansicht des Beitrags:
Von:
Gast14221
Datum:
18.10.2017 12:19:03
Views:
674
Rating: Antwort:
  Ja
Thema:
Abgeschlossen...Code jetzt richtig...
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
Option Explicit
     
     
    Sub Transfer_Data()
        Dim ws_Daten As Worksheet
        Dim rowsToCopy As Variant
        Dim rng, tmp As Range
        Dim wb As Workbook
        Dim lRow As Long
         
        Set wb = Workbooks.Open("Workbook mit Daten")
        wb.Unprotect "Passwort des Workbooks"
         
        Set ws_Daten = wb.Sheets(1) 'Anpassen
        With ws_Daten
            lRow = .Cells(.Rows.Count, 4).End(xlUp).Row
            Set rng = .Range(.Cells(1, 4), .Cells(lRow, 4))
            rowsToCopy = Get_Row_Array(rng, "T_TL xxx oooo")
            If IsArray(rowsToCopy) Then
                Transfer_data_To_other_Workbook rowsToCopy, ws_Daten
            End If
        End With
     
        wb.Protect "Passwort des Workbooks"
     
    End Sub
     
     
    Private Function Get_Row_Array(ByVal rng As Range, ByVal ValueToFind As Variant) As Variant
        Dim array_() As Variant
        Dim counter As Long
        Dim firstAddress
        Dim c As Range
         
         
        With rng
            Set c = .Find(ValueToFind, LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                firstAddress = c.Address
                counter = 0
                Do
                    ReDim Preserve array_(counter)
                    array_(counter) = c.Row
                    counter = counter + 1
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        End With
         
        Get_Row_Array = array_
         
    End Function
     
     
    Private Function Transfer_data_To_other_Workbook(ByVal array_ As Variant, ByVal FromWorksheet  _
    As Worksheet)
        Dim varItem As Variant
        Dim ws As Worksheet
        Dim wb As Workbook
        Dim lRow As Long
        Dim tmp As Range
         
         
        Set ws = ThisWorkbook.Sheets("Worksheet wo es rein soll")
         
        With ws
            lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                     
            For Each varItem In array_
                With FromWorksheet
                    Set tmp = .Range(.Cells(varItem, 2), .Cells(varItem, 4))
                End With
                .Range("A" & lRow).Resize(, tmp.Columns.Count) = tmp.Value
                Set tmp = Nothing
                lRow = lRow + 1
            Next varItem
             
        End With

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
18.10.2017 08:38:48 Chris
NotSolved
18.10.2017 09:33:53 Chris
NotSolved
18.10.2017 12:12:35 Gast31549
NotSolved
Blau Abgeschlossen...Code jetzt richtig...
18.10.2017 12:19:03 Gast14221
NotSolved