Thema Datum  Von Nutzer Rating
Antwort
18.10.2017 12:07:43 Thomas
NotSolved
Blau Code Lösung aus Herber Forum
18.10.2017 12:20:57 Gast59316
NotSolved
19.10.2017 15:10:11 Gast33356
NotSolved

Ansicht des Beitrags:
Von:
Gast59316
Datum:
18.10.2017 12:20:57
Views:
677
Rating: Antwort:
  Ja
Thema:
Code Lösung aus Herber Forum
Option Explicit
Private bank_1 As Workbook
Private bank_2 As Workbook
Private Const bank1_Path As String = "C:\Dein\Pfad\zur\Bankdatei 1.xlsx"
Private Const bank2_Path As String = "C:\Dein\Pfad\zur\Bankdatei 2.xlsx"


Sub Transfer_Data()
    Dim lRow, counter_1, counter_2 As Long
    Dim array_1, array_2 As Variant
    Dim ws As Worksheet
    Dim rng As Range
    

    If Try_To_Access_Sheet Then
        Set ws = ThisWorkbook.Sheets("Transaktionen")
        With ws
            lRow = .Cells(.Rows.Count, 3).End(xlUp).Row
            Set rng = .Range(.Cells(5, 3), .Cells(lRow, 3))
        End With
        
        '//Get the Size of the arrays
        counter_1 = CountOccurence("Bank 1", rng): If counter_1 >= 1 Then ReDim array_1( _
counter_1 - 1)
        counter_2 = CountOccurence("Bank 2", rng): If counter_2 >= 1 Then ReDim array_2( _
counter_2 - 1)
        
        '//Save range values in the arrays
        Get_Bank_Ranges array_1, array_2
        
        '//Put data into the files
        If Not IsEmpty(array_1) Then To_Bank1 array_1
        If Not IsEmpty(array_2) Then To_Bank2 array_2
        
        bank_1.Close True
        bank_2.Close True
        Set rng = Nothing
        Set ws = Nothing
        
    Else
        MsgBox "Bank Dateien konnten nicht geöffnet werden"
    End If

End Sub



Private Function Try_To_Access_Sheet() As Boolean
    Dim wb1, wb2 As Workbook
    
    On Error GoTo ErrHandler
    Set bank_1 = Workbooks.Open(bank1_Path)
    Set bank_2 = Workbooks.Open(bank2_Path)
    Try_To_Access_Sheet = True
    Exit Function
    
ErrHandler:
    
    Set bank_1 = Nothing: Set bank_2 = Nothing
    
End Function


Private Function CountOccurence(ByVal Of_ As String, ByVal rng As Range)
    Dim c As Range
    For Each c In rng
        If c.Value = Of_ Then
            CountOccurence = CountOccurence + 1
        End If
    Next c
End Function


Private Function Get_Bank_Ranges(ByRef array_1, array_2 As Variant) As Boolean
    Dim lRow, counter_1, counter_2 As Long
    Dim rng, tmp, c As Range
    Dim ws As Worksheet
        
    counter_1 = 0: counter_2 = 0
    Set ws = ThisWorkbook.Sheets("Transaktionen")
    With ws
        lRow = .Cells(.Rows.Count, 3).End(xlUp).Row
        Set rng = .Range(.Cells(5, 3), .Cells(lRow, 3))
        For Each c In rng
            If Not c Is Nothing And c.Value <> "" Then
                Set tmp = .Range(.Cells(c.Row, 2), .Cells(c.Row, 7))
                If c.Value = "Bank 1" Then array_1(counter_1) = tmp.Value: counter_1 =  _
counter_1 + 1
                If c.Value = "Bank 2" Then array_2(counter_2) = tmp.Value: counter_2 =  _
counter_2 + 1
            End If
        Next c
    End With

End Function


Private Function To_Bank1(ByVal array_ As Variant)
    Dim values_, varItem, tmp As Variant
    Dim ws_1, ws_2 As Worksheet
    Dim lRow As Long
    
    Set ws_1 = bank_1.Sheets("Firma 1")
    Set ws_2 = bank_1.Sheets("Firma 2")
    
    For Each varItem In array_
        tmp = varItem
        If tmp(1, 1) = "Firma 1" Then
            With ws_1
                lRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
                .Cells(lRow, 2).Value = tmp(1, 4)
                .Cells(lRow, 3).Value = tmp(1, 3)
                If tmp(1, 6) = "USD" Then .Cells(lRow, 5).Value = tmp(1, 5)
                If tmp(1, 6) = "EUR" Then .Cells(lRow, 7).Value = tmp(1, 5)
            End With
        ElseIf tmp(1, 1) = "Firma 2" Then
            With ws_2
                lRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
                .Cells(lRow, 2) = tmp.Cells(1, 4).Value
                .Cells(lRow, 3).Value = tmp(1, 3)
                If tmp(1, 6) = "USD" Then .Cells(lRow, 5) = tmp(1, 5)
                If tmp(1, 6) = "EUR" Then .Cells(lRow, 7) = tmp(1, 5)
            End With
        End If
    Next varItem
        
    Set ws_1 = Nothing: Set ws_2 = Nothing
    
End Function


Private Function To_Bank2(ByVal array_ As Variant)
    Dim values_, varItem, tmp As Variant
    Dim ws_1, ws_2 As Worksheet
    Dim lRow As Long
    
    Set ws_1 = bank_2.Sheets("Firma 1")
    Set ws_2 = bank_2.Sheets("Firma 2")
    
    For Each varItem In array_
        tmp = varItem
        If tmp(1, 1) = "Firma 1" Then
            With ws_1
                lRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
                .Cells(lRow, 2).Value = tmp(1, 4)
                .Cells(lRow, 3).Value = tmp(1, 3)
                If tmp(1, 6) = "USD" Then .Cells(lRow, 5).Value = tmp(1, 5)
                If tmp(1, 6) = "EUR" Then .Cells(lRow, 7).Value = tmp(1, 5)
            End With
        ElseIf tmp(1, 1) = "Firma 2" Then
            With ws_2
                lRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
                .Cells(lRow, 2) = tmp.Cells(1, 4).Value
                .Cells(lRow, 3).Value = tmp(1, 3)
                If tmp(1, 6) = "USD" Then .Cells(lRow, 5) = tmp(1, 5)
                If tmp(1, 6) = "EUR" Then .Cells(lRow, 7) = tmp(1, 5)
            End With
        End If
    Next varItem
    
    Set ws_1 = Nothing: Set ws_2 = Nothing
    
End Function

 


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 12:07:43 Thomas
NotSolved
Blau Code Lösung aus Herber Forum
18.10.2017 12:20:57 Gast59316
NotSolved
19.10.2017 15:10:11 Gast33356
NotSolved