@ Joachim Röder
Josef
Unser Thread ist ins Archiv gerutscht!
Hatte das mit den Tabellennamen gestern übersehen!
Hier das Makro.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub Daten_übertragen(Quelltabelle As String, Quellbereiche As String, Zielbereiche As String)
Dim objWbVA As Workbook
Dim objShDaten As Worksheet, objShVA As Worksheet
Dim strFile As String
Dim lngCalculation As Long
Dim rng As Range
Dim blnWasOpen As Boolean
Dim varQR As Variant, varZR As Variant
Dim intIndex As Integer, intColDif As Integer, lngRowDif As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
lngCalculation = .Calculation
.Calculation = xlCalculationManual
.Cursor = xlWait
End With
strFile = ThisWorkbook.Path & "\VERARBEITUNG.xls"
On Error Resume Next
blnWasOpen = True
Set objWbVA = Workbooks("VERARBEITUNG.xls")
If Err.Number > 0 Then
Err.Clear
On Error GoTo ErrExit
Set objWbVA = Workbooks.Open(strFile)
blnWasOpen = False
End If
Set objShVA = objWbVA.Sheets("Tabelle1")
Set objShDaten = ThisWorkbook.Sheets(Quelltabelle)
varQR = Split(Quellbereiche, ";")
varZR = Split(Zielbereiche, ";")
If UBound(varQR) <> UBound(varZR) Then
MsgBox "Anzahl der Bereiche ist unterschiedlich!", vbExclamation, "Hinweis"
GoTo ErrExit
End If
With objShVA
.Unprotect Password:=""
For intIndex = 0 To UBound(varQR)
intColDif = Range(Trim$(varZR(intIndex))).Column - Range(Trim$(varQR(intIndex))).Column
lngRowDif = Range(Trim$(varZR(intIndex))).Row - Range(Trim$(varQR(intIndex))).Row
For Each rng In objShDaten.Range(Trim$(varQR(intIndex)))
If rng <> "" And rng <> 0 Then
.Cells(rng.Row + lngRowDif, rng.Column + intColDif) = rng.Value
End If
Next
Next
.Protect Password:="", UserInterfaceOnly:=True
End With
ErrExit:
If Not objWbVA Is Nothing And Not blnWasOpen Then objWbVA.Close True
If Err.Number > 0 Then
If Err.Number = 1004 Then
MsgBox "Die Zielmappe ist nicht vorhanden - Abbruch", 48, "Abbruch!"
Else
MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
End If
Err.Clear
Else
MsgBox "Die Daten wurden erfolgreich übertragen!", 64, "Hinweis"
End If
Set objWbVA = Nothing
Set objShVA = Nothing
Set objShDaten = Nothing
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = lngCalculation
.Cursor = xlDefault
End With
End Sub
Und so sieht der Aufruf aus!
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub Daten_übertragen(Quelltabelle As String, Quellbereiche As String, Zielbereiche As String)
Dim objWbVA As Workbook
Dim objShDaten As Worksheet, objShVA As Worksheet
Dim strFile As String
Dim lngCalculation As Long
Dim rng As Range
Dim blnWasOpen As Boolean
Dim varQR As Variant, varZR As Variant
Dim intIndex As Integer, intColDif As Integer, lngRowDif As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
lngCalculation = .Calculation
.Calculation = xlCalculationManual
.Cursor = xlWait
End With
strFile = ThisWorkbook.Path & "\VERARBEITUNG.xls"
On Error Resume Next
blnWasOpen = True
Set objWbVA = Workbooks("VERARBEITUNG.xls")
If Err.Number > 0 Then
Err.Clear
On Error GoTo ErrExit
Set objWbVA = Workbooks.Open(strFile)
blnWasOpen = False
End If
Set objShVA = objWbVA.Sheets("Tabelle1")
Set objShDaten = ThisWorkbook.Sheets(Quelltabelle)
varQR = Split(Quellbereiche, ";")
varZR = Split(Zielbereiche, ";")
If UBound(varQR) <> UBound(varZR) Then
MsgBox "Anzahl der Bereiche ist unterschiedlich!", vbExclamation, "Hinweis"
GoTo ErrExit
End If
With objShVA
.Unprotect Password:=""
For intIndex = 0 To UBound(varQR)
intColDif = Range(Trim$(varZR(intIndex))).Column - Range(Trim$(varQR(intIndex))).Column
lngRowDif = Range(Trim$(varZR(intIndex))).Row - Range(Trim$(varQR(intIndex))).Row
For Each rng In objShDaten.Range(Trim$(varQR(intIndex)))
If rng <> "" And rng <> 0 Then
.Cells(rng.Row + lngRowDif, rng.Column + intColDif) = rng.Value
End If
Next
Next
.Protect Password:="", UserInterfaceOnly:=True
End With
ErrExit:
If Not objWbVA Is Nothing And Not blnWasOpen Then objWbVA.Close True
If Err.Number > 0 Then
If Err.Number = 1004 Then
MsgBox "Die Zielmappe ist nicht vorhanden - Abbruch", 48, "Abbruch!"
Else
MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
End If
Err.Clear
Else
MsgBox "Die Daten wurden erfolgreich übertragen!", 64, "Hinweis"
End If
Set objWbVA = Nothing
Set objShVA = Nothing
Set objShDaten = Nothing
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = lngCalculation
.Cursor = xlDefault
End With
End Sub
Und so sieht der Aufruf aus!
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Private Sub CommandButton1_Click()
Call Daten_übertragen("Tabelle1", "K8:O14;K16:O18", "E9;E16")
'Parameter = (Quelltabellenname,Quellbereich(e),Zielbereich(e))
'Die einzelnen Bereiche durch ; trennen "Quellbereich1;Quellbereich2", "Zielbereich1;Zielbereich2")!
'Bei den Zielbereichen genügt es, die erste Zelle anzugeben!
'Es können auch mehr als zwei Bereiche angegeben werden!
'Die Anzahl der Quell- und Zielbereiche muss identisch sein!
End Sub
Ich hoffe du kommst damit klar!
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Private Sub CommandButton1_Click()
Call Daten_übertragen("Tabelle1", "K8:O14;K16:O18", "E9;E16")
'Parameter = (Quelltabellenname,Quellbereich(e),Zielbereich(e))
'Die einzelnen Bereiche durch ; trennen "Quellbereich1;Quellbereich2", "Zielbereich1;Zielbereich2")!
'Bei den Zielbereichen genügt es, die erste Zelle anzugeben!
'Es können auch mehr als zwei Bereiche angegeben werden!
'Die Anzahl der Quell- und Zielbereiche muss identisch sein!
End Sub
Ich hoffe du kommst damit klar!
'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************
@ Josef Ehrensberger
Joachim
Hallo Sepp,
nach einem Inet-Down melde ich mich jetzt erst.
Alles bestens - vielen lieben Dank.
Ich denke nun ist es alles so wie es sein soll.
Viele Grüße
Joachim
AW: @ Josef Ehrensberger
Joachim
Hallo Sepp,
ich habe deinen Code zwar so drin wie es sein soll und es kalppt auch alles,
aber ich habe auch noch andere Codes die mit eingebunden sein sollen und dabei habe ich einfach das Problem, dass vieles ein wenig durcheinander kommt.
Vielleicht kannst du bitte einmal reinschauen und mir nocheinmal behilflich sein.
Die ganze Situation habe ich im Thread:
https://www.herber.de/forum/messages/734331.html
Gruß
Joachim
Ich habe dir im anderen Thread geantwortet! o.T.
Josef