Arbeiten mit zwei Mappen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Kira!
Wenn der Tabellenaufbau deiner Beispiele stimmt und die Tabelle immer
den Namen der Datei trägt, dann sollte das Klappen!
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Extern()
Dim strFile As String, strSheet As String
Dim dDate As Date
Dim varValues As Variant
Dim objFSO As Object
Dim rngFind As Range, rng As Range
Dim lngR As Long

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

If strFile = "Falsch" Then Exit Sub

Set objFSO = CreateObject("Scripting.FileSystemObject")

strSheet = objFSO.GetBaseName(strFile)

dDate = DateValue("01/" & Replace(strSheet, "_", " "))

With ExcelTable(strFile, strSheet, "A1:D65536")
  varValues = .GetRows
  .Close
End With

With Sheets("Menge")
  Set rngFind = .Rows(2).Find(dDate)

  If Not rngFind Is Nothing Then
    For Each rng In .Range(.Cells(3, 2), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 2))
      For lngR = 0 To UBound(varValues, 2)
        If rng = varValues(1, lngR) Then
          .Cells(rng.Row, rngFind.Column) = varValues(2, lngR)
          Exit For
        End If
        .Cells(rng.Row, rngFind.Column) = 0
      Next
    Next
  End If

End With

Set objFSO = Nothing
Set rngFind = Nothing
End Sub

Public Function ExcelTable(ByRef Path As String, ByRef Table As String, ByRef SourceRange As String) As Object
Dim SQL As String
Dim Con As String

SQL = "select * from [" & Table & "$" & SourceRange & "]"
Con = "Provider=Microsoft.Jet.OLEDB.4.0;" _
  & "Extended Properties=Excel 8.0;" _
  & "Data Source=" & Path & ";"
Set ExcelTable = CreateObject("ADODB.Recordset")
ExcelTable.Open SQL, Con, 1, 3
End Function

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Hallo Kira!
Nächstesmal bitte gleich die richtige Beschreibung der Aufgabe,
dann braucht man nicht einen laufenden Code wieder umbauen!
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Extern()
Dim strFile As String, strSheet As String, strDate As String
Dim dDate As Date
Dim varValues As Variant
Dim objFSO As Object
Dim rngFind As Range, rng As Range
Dim lngR As Long, lngLast As Long, lngNew As Long

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

If strFile = "Falsch" Then Exit Sub

Set objFSO = CreateObject("Scripting.FileSystemObject")

strDate = objFSO.GetBaseName(strFile)

dDate = DateValue("01/" & Replace(strDate, "_", " "))

strSheet = "Tabelle1"

With ExcelTable(strFile, strSheet, "A1:D65536")
  varValues = .GetRows
  .Close
End With

With Sheets("Menge")
  lngLast = .Cells(Rows.Count, 1).End(xlUp).Row
  lngNew = lngLast + 1
  Set rngFind = .Rows(2).Find(dDate)

  If Not rngFind Is Nothing Then
    For lngR = 0 To UBound(varValues, 2)
      Set rng = .Range(.Cells(3, 2), .Cells(lngLast, 2)).Find(varValues(1, lngR), lookat:=xlWhole)
      If Not rng Is Nothing Then
        .Cells(rng.Row, rngFind.Column) = varValues(2, lngR)
      Else
        If Left(UCase(varValues(1, lngR)), 1) Like "[M-Z]" Then ' [A-L] für A bis L
          .Cells(lngNew, 1) = varValues(0, lngR)
          .Cells(lngNew, 2) = varValues(1, lngR)
          .Cells(lngNew, rngFind.Column) = varValues(2, lngR)
          lngNew = lngNew + 1
        End If
      End If
    Next
  End If

  .Range(.Cells(2, 1), .Cells(lngNew, .Cells(2, Columns.Count).End(xlToLeft).Column)).Sort _
    Key1:=Range("B3"), _
    Order1:=xlAscending, _
    Header:=xlYes
End With

Set objFSO = Nothing
Set rngFind = Nothing
End Sub

Public Function ExcelTable(ByRef Path As String, ByRef Table As String, ByRef SourceRange As String) As Object
Dim SQL As String
Dim Con As String

SQL = "select * from [" & Table & "$" & SourceRange & "]"
Con = "Provider=Microsoft.Jet.OLEDB.4.0;" _
  & "Extended Properties=Excel 8.0;" _
  & "Data Source=" & Path & ";"
Set ExcelTable = CreateObject("ADODB.Recordset")
ExcelTable.Open SQL, Con, 1, 3
End Function

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread