Spalte in anderer Tabelle nach Werten durchsuchen

Hi,
das sollte es tuen. Ich habe mich akribisch an deine Vorgaben (Tabellennamen, Spalten) aus dem Beitrag gehalten. Wenn in deiner Masterdatei irgendwas anders heisst, musst du entsprechend umbenennen. Ich gehe davon aus, dass in Zelle A1 (also in Zeile 1) niemals eine Summe stehen wird!

Sub CheckeSummeInExternemFIle()
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim lRow As Long
Dim lWert As Double
'aktuelle Datei merken, neue Datei öffnen
Set wkbOld = ActiveWorkbook
Call FileCheckOpen("C:\TestTmp", "Datei1.xlsm") 'ANPASSEN
'neue Datei merken
Set wkbNew = ActiveWorkbook
Sheets("Tabelle1").Activate                     'ANPASSEN
With ActiveSheet
'letzte Zeile
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'Autofilter nutzen, um das Wort "Summe" zu finden
'geht VIEL schneller als eine Schleife über jede Zelle!
If .AutoFilterMode Then .Cells.AutoFilter
.Range("A1").Value = "TEMP" 'Autofilter braucht eine gefüllte erste Zelle
.Range(.Cells(1, 1), .Cells(lRow, 1)).AutoFilter
.Range("A1").AutoFilter Field:=1, Criteria1:="=Summe"
'Summe ermitteln, falls es eine gibt (sonst null)
lWert = Application.WorksheetFunction.Sum(.Range("B1:CP" & lRow).SpecialCells( _
xlCellTypeVisible))
End With
'Datei schließen ohne speichern
wkbNew.Close False
'alte Datei aktivieren
wkbOld.Activate
Sheets("Tabelle2").Activate
With ActiveSheet
'"Beispiel+Tabelle2" in der nächsten freien Zelle der Spalte J ausgegeben werden
lRow = .Cells(.Rows.Count, 10).End(xlUp).Row + 1
.Range("J" & lRow).Value = lWert
End With
End Sub
'*********************************************************************************************** _
'* Module to open needed files. Checks if Files are open or not.
'* If file is already open, do nothing - else open it
'* stolen from: https://www.herber.de/mailing/Pruefen_ob_Arbeitsmappe_geoeffnet_und_wenn_nein_oeffnen.htm
'* modified by Klaus MvdT / 16.NOV.2012
'*********************************************************************************************** _
'Example:
'Call FileCheckOpen("C:\TMP", "Filename.xls")
'path and filename can be RANGE from excelsheet
Sub FileCheckOpen(sPath As String, sFile As String)
sPath = sPath & "/" & sFile
If WkbExists(sFile) = False Then
If Dir(sPath) = "" Then
MsgBox "File " & sPath & " not found!"
Else
Workbooks.Open sPath, UpdateLinks:=False
End If
Else
Workbooks(sFile).Activate
End If
End Sub
Private Function WkbExists(sFile As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Not wkb Is Nothing Then
WkbExists = True
End If
On Error GoTo 0
End Function

Grüße,
Klaus M.vdT.

Hi,
ich weiss absolut nicht worauf du hinaus möchtest. Statt zu raten, was dein Code bewirken soll, habe ich den Windows FilePicker in das Makro eingebaut.
ChDir "C:\TestTMP"
Hier deinen Pfad angeben!

Option Explicit
Sub CheckeSummeInExternemFIle()
On Error GoTo hell
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim lRow As Long
Dim lWert As Double
'aktuelle Datei merken, neue Datei öffnen
Set wkbOld = ActiveWorkbook
ChDir "C:\TestTMP"
Call FileCheckOpen(GetFile) 'ANPASSEN
'neue Datei merken
Set wkbNew = ActiveWorkbook
Sheets("Tabelle1").Activate                     'ANPASSEN
With ActiveSheet
'letzte Zeile
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'Autofilter nutzen, um das Wort "Summe" zu finden
'geht VIEL schneller als eine Schleife über jede Zelle!
If .AutoFilterMode Then .Cells.AutoFilter
.Range("A1").Value = "TEMP" 'Autofilter braucht eine gefüllte erste Zelle
.Range(.Cells(1, 1), .Cells(lRow, 1)).AutoFilter
.Range("A1").AutoFilter Field:=1, Criteria1:="=Summe"
'Summe ermitteln, falls es eine gibt (sonst null)
lWert = Application.WorksheetFunction.Sum(.Range("B1:CP" & lRow).SpecialCells( _
xlCellTypeVisible))
End With
'Datei schließen ohne speichern
wkbNew.Close False
'alte Datei aktivieren
wkbOld.Activate
Sheets("Tabelle2").Activate
With ActiveSheet
'"Beispiel+Tabelle2" in der nächsten freien Zelle der Spalte J ausgegeben werden
lRow = .Cells(.Rows.Count, 10).End(xlUp).Row + 1
.Range("J" & lRow).Value = lWert
End With
GoTo heaven
hell:
MsgBox ("Abgebrochen!")
heaven:
End Sub
Function GetFile()
Dim varDatei As Variant
varDatei = Application.GetOpenFilename()
If varDatei = False Then
MsgBox "Der Benutzer hat abgebrochen.", vbInformation
Else
GetFile = varDatei
End If
End Function
'*********************************************************************************************** _
_
'* Module to open needed files. Checks if Files are open or not.
'* If file is already open, do nothing - else open it
'* stolen from: https://www.herber.de/mailing/Pruefen_ob_Arbeitsmappe_geoeffnet_und_wenn_nein_oeffnen.htm
'* modified by Klaus MvdT / 16.NOV.2012
'*********************************************************************************************** _
_
'Example:
'Call FileCheckOpen("C:\TMP", "Filename.xls")
'path and filename can be RANGE from excelsheet
Sub FileCheckOpen(sPath As String)
'sPath = sPath & "/" & sFile
If WkbExists(sPath) = False Then
If Dir(sPath) = "" Then
MsgBox "File " & sPath & " not found!"
Else
Workbooks.Open sPath, UpdateLinks:=False
End If
Else
Workbooks(sPath).Activate
End If
End Sub
Private Function WkbExists(sFile As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Not wkb Is Nothing Then
WkbExists = True
End If
On Error GoTo 0
End Function

Grüße,
Klaus M.vdT.

Spalte in anderer Tabelle nach Werten durchsuchen

Forumthread: Spalte in anderer Tabelle nach Werten durchsuchen

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Spalte in anderer Tabelle nach Werten durchsuchen

Forumthread: Spalte in anderer Tabelle nach Werten durchsuchen

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread