Daten in Mappe mit anderem Bereich übertragen

Hallo zusammen!
Ich bin auf der Suche nach einem Makro, die (z.B.) Artikelnummern in zwei unterschiedlichen Arbeitsblättern vergleicht und bei Übereinstimmung vorhandene Wert überträgt.
Zum besseren Verständnis:
Quelldatei: (Quelle.xls)
In der Quelldatei befinden sich in (z.B.) Tabelle5 in der Spalte A die Artikelnummern. In Spalte B befindet sich die Anzahl der verkauften Exemplare. Der Eintrag der Werte erfolgte auf der Basis einer Verknüpfung zu einem anderen Tabellenblatt; die Tabelle 5 ist also eine Hilfstabelle, die die Verknüpfungsergebnisse darstellt.
Es soll beim Anstoßen des Makros (aus der Quelldatei) das Auswahlfenster eingeblendet werden, aus dem die Zieldatei ausgesucht werden muss. Nach dem Aufrufen der Zieldatei sollen die Daten nach Abgleich der Artikelnummern übertragen werden.
Zieldatei:(Ziel.xls; hat nur 1 Sheet)
Es sollen nun die Artikelnummern in der Zieldatei verglichen werden. Die gleichen Artikelnumern befinden sich dort ebenfalls in Spalte A.
Die aus der Quelldatei zu übernehmenden Daten (dort Spalte B) befinden sich hier aber nicht in Spalte B, sondern in Spalte G; und zwar in einem begrenzten Bereich G14 : G80.
Besonderheit:
Nach dem Befüllend er Zieldatei soll diese gespeichert werden; und zwar unter dem Namen, der sich aus der Zelle B9 der Zieldatei ergibt.
Die Originalzieldatei soll wieder geschlossen werden und wieder im ursprünglichen Zustand, also als leeres Formular zur Verfügung stehen; also schließen ohne speichern.
Für Hilfe wäre ich sehr dankbar, meine Kenntnisse an ihre Grenzen gestoßen sind; und zwar insbesondere beim Übertrag der Daten.
Hier die Quell- und Zieldatei. Ich habe in den Sheets entsprechende Hinweise germacht.

Die Datei https://www.herber.de/bbs/user/60184.xls wurde aus Datenschutzgründen gelöscht

https://www.herber.de/bbs/user/60185.xls
Danke vorab.
Dietmar Z.
Für Sepp: mir war nicht ganz klar wie ich Dich hier im Forum direkt erreichen kann. Vielleicht liest Du ja diese Nachricht.

Hallo Dietmar,
der angepasste Code sollte es tun.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub DatenUebertragen()
  Dim strFile As String, strNewName As String
  Dim objWB As Workbook, objWS As Worksheet, objTarget As Worksheet
  Dim rng As Range, rngF As Range, rngC As Range
  Dim blnOpen As Boolean
  Dim lngRow As Long, lngLast As Long, lngN As Long
  Dim varResult As Variant

  On Error GoTo ErrExit
  GMS

  strFile = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
    "*.xls; *.xlsx; *.xlsm")

  If strFile = "Falsch" Or strFile = ThisWorkbook.FullName Then GoTo ErrExit

  blnOpen = IsOpen(strFile)

  If blnOpen Then
    Set objWB = Workbooks(Mid(strFile, InStrRev(strFile, "\") + 1))
  Else
    Set objWB = Workbooks.Open(strFile)
  End If

  Set objTarget = objWB.Sheets("Tabelle1")

  For Each objWS In ThisWorkbook.Worksheets
    With objWS
      Select Case .Name
        Case "PersonalDaten"
          objTarget.Cells(6, 2) = .Cells(2, 2)
          objTarget.Cells(7, 2) = .Cells(3, 2)
          For lngRow = 4 To 7
            objTarget.Cells(lngRow + 6, 2) = .Cells(lngRow, 2)
          Next
        Case "BelegeMarken"
          lngN = 2
          For lngRow = 66 To 71
            objTarget.Cells(lngRow, 3) = .Cells(lngN, 2)
            objTarget.Cells(lngRow, 4) = .Cells(lngN + 3, 2)
            lngN = lngN + 1
            If lngN = 5 Then lngN = 8
          Next
        Case "Gewicht"
          For lngRow = 2 To 6
            objTarget.Cells(lngRow + 189, IIf(lngRow < 5, 3, 2)) = .Cells(lngRow, 2)
          Next
        Case "PV"
          Set rng = .Range("D2:D" & .Cells(Rows.Count, 4).End(xlUp).Row)
          Set rngF = objTarget.Range("A76:A183")

          For Each rngC In rng
            If rngC <> "" And IsNumeric(rngC) Then
              varResult = Application.Match(rngC.Offset(0, -3), rngF, 0)
              If IsNumeric(varResult) Then
                objTarget.Cells(varResult + 75, 4) = rngC
              End If
            End If
          Next
        Case "TN"
          Set rng = .Range("C2:C" & .Cells(Rows.Count, 3).End(xlUp).Row)
          Set rngF = objTarget.Range("A16:A62")
          For Each rngC In rng
            If rngC <> "" And IsNumeric(rngC) Then
              varResult = Application.Match(rngC.Offset(0, -2), rngF, 0)
              If IsNumeric(varResult) Then
                objTarget.Cells(varResult + 15, 7) = rngC
              End If
            End If
          Next
        Case Else
      End Select
    End With
  Next

  Application.Calculate
  strNewName = "Etally" & objTarget.Cells(9, 2).Text & Mid(objWB.Name, InStrRev(objWB.Name, "."))
  'strNewName = objTarget.Cells(9, 2).Text & Mid(objWB.Name, InStrRev(objWB.Name, ".")) 'ohne des Namenszusatz Etally

  'objWB.SaveAs objWB.Path & "\" & strNewName 'Speichern im gleichen Ordner wie die Original-Zieldatei
  objWB.SaveAs "C:\MLC2008" & "\" & strNewName 'Speichern unter vorgegebenem Pfad

  'strSaveAsName = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xls; *.xlsx; *.xlsm)," & _
    ' "*.xls; *.xlsx; *xlsm", InitialFileName:=strNewName, Title:="Überprüfen sie den Dateinamen/Pfad!") 'Speicherpfad abfragen
  objWB.Close

  MsgBox "Die Datei " & strNewName & " wurde erfolgreich gespeichert.", vbInformation, "MLC2008 Meeting-Leader-Calculator"

  ErrExit:

  With Err
    If .Number = 1004 And .Description Like "*schreibgeschützt*" Then
      .Clear
      Resume Next
    End If
    If .Number <> 0 Then MsgBox .Number & vbLf & vbLf & .Description, vbExclamation, "Fehler"
  End With
  GMS True
  Set objWB = Nothing
  Set objWS = Nothing
  Set rng = Nothing
  Set rngF = Nothing
  Set rngC = Nothing
End Sub

Private Sub GMS(Optional ByVal Modus As Boolean = False)

  Static lngCalc As Long

  With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Not Modus Then lngCalc = .Calculation
    If Modus And lngCalc = 0 Then lngCalc = -4105
    .Calculation = IIf(Modus, lngCalc, -4135)
    .Cursor = IIf(Modus, -4143, 2)
  End With

End Sub

Private Function IsOpen(ByVal WBFullName As String) As Boolean
  Dim objWB As Workbook
  For Each objWB In Application.Workbooks
    If objWB.FullName = WBFullName Then
      IsOpen = True
      Exit For
    End If
  Next
End Function

Gruß Sepp

Daten in Mappe mit anderem Bereich übertragen

Forumthread: Daten in Mappe mit anderem Bereich übertragen

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Daten in Mappe mit anderem Bereich übertragen

Forumthread: Daten in Mappe mit anderem Bereich übertragen

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread