AW: Daten aus einer Datei in andere Datein kopieren
18.10.2017 08:51:35
Peter(silie)
Hallo,
hier deine Mappe: https://www.herber.de/bbs/user/117036.xlsm
Du musst die Pfade zu den Bank Dateien auf dich anpassen!
Das Makro ist nicht optimiert, evtl. nicht fehlerfrei und wurde von mir
nur rudimentär getestet.
Hier nur Code:
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