Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
208to212
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
208to212
208to212
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Zugriff auf geschlossene Mappen

Zugriff auf geschlossene Mappen
25.01.2003 18:11:34
step
Hallo,
wollte das Beispiel für Zugriff auf geschlossene Mappen finden.
Kann jemand sagen, wo ich das finde, oder wie das Makro lautet.
Gruss
Step

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: Zugriff auf geschlossene Mappen
25.01.2003 20:16:33
Wolfgang
nein, weiß ich nicht, aber ich hatte das Problem auch und erfuhr, daß man nicht drumrum kommt, die Mappe per VBA öffnen zu müssen. Denke den Befehl kennst Du
Re: Zugriff auf geschlossene Mappen
25.01.2003 20:48:32
Step
Hi, danke, aber ich habe es gefunden. Läuft sehr gut

Modul:basFunktions

Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetDirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, pos - 1)
Else
GetDirectory = ""
End If
End Function

Function RealLastCell(TheSheet As Worksheet) As Range
Dim ExcelLastCell As Range
Dim Row%, Col%, LastRowWithData%, LastColWithData%
Application.ScreenUpdating = False
Set ExcelLastCell = TheSheet.Cells.SpecialCells(xlLastCell)
LastRowWithData = ExcelLastCell.Row
Row = ExcelLastCell.Row
Do While Application.CountA(TheSheet.Rows(Row)) = 0 And Row <> 1
Row = Row - 1
Loop
LastRowWithData = Row
LastColWithData = ExcelLastCell.Column
Col = ExcelLastCell.Column
Do While Application.CountA(TheSheet.Columns(Col)) = 0 And Col <> 1
Col = Col - 1
Loop
LastColWithData = Col
Set RealLastCell = TheSheet.Cells(Row, Col)
End Function
-----------------------------------------------------
Modul: basMAin

Sub DatenSammeln()
Dim wks As Worksheet
Dim fs As FileSearch
Dim rng As Range
Dim iCounter As Integer, iRow As Integer
Dim sMsg As String, sDir As String
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo ERRORHANDLER
sMsg = "Wählen Sie bitte einen Ordner aus:"
sDir = GetDirectory(sMsg)
If sDir = "" Then Exit Sub
Set wks = ActiveSheet
iRow = 3
Set fs = Application.FileSearch
With fs
.LookIn = sDir
.FileType = msoFileTypeExcelWorkbooks
.Execute
For iCounter = 1 To .FoundFiles.Count
Workbooks.Open _
FileName:=.FoundFiles(iCounter), _
updatelinks:=False
wks.Cells(iRow - 2, 1).Value = ActiveWorkbook.Name & ":"
Set rng = RealLastCell(ActiveSheet)
Set rng = Range(Cells(1, 1), rng)
rng.Copy wks.Cells(iRow, 1)
iRow = iRow + rng.Rows.Count + 3
Application.CutCopyMode = False
ActiveWorkbook.Close savechanges:=False
Next iCounter
End With
ERRORHANDLER:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Gruss
Step

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige