Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
732to736
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
732to736
732to736
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

@ Joachim Röder

@ Joachim Röder
Josef
Hallo Joachim!
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: 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!
'******************************

@ 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

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
@ Josef Ehrensberger
17.02.2006 09:32:56
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
19.02.2006 12:37:04
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
Anzeige
Ich habe dir im anderen Thread geantwortet! o.T.
19.02.2006 14:00:11
Josef

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige