da fällt mir noch eine interessante sache ein.
also wie beschrieben suche ich ja mit einer vorlage in der man verschiedene merkmale auswählen kann etwas aus anderen excel-dateien und diese werde dann alle in eine txt-datei gespeichert.
dazu nun eine frage gibt es eine möglichkeit das nach durchlaufen der ganzen geschichte der ordner wo ich die ausgabedatei speichere auf-"popt" ?...
sollte noch erwähnen dass sich der ordner verändern kann, weil man jedes mal aussuchen kann wo gespeichert und auch ausgelesen wird...
falk
ps: anbei mein schatz :)
'data type for directory dialog
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
'32-bit API declarations for directoy dialog
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
Public Sub TextNoModification()
Const DELIMITER As String = vbTab
Dim myRecord As Range
Dim myField As Range
Dim nFileNum As Long
Dim sOut As String
Dim wb As New Workbook
Dim ws As New Worksheet
Dim vntsVariables As Variant
Dim strsValues() As String
Dim strsCheckVariables() As String
Dim vntsSubFolders As Variant
Dim Zelle As Excel.Range
'If cell.index-color = red and cell(,1) <> null then selection
ActiveSheet.Range("B1:B400").Select
With ActiveSheet
For Each Zelle In Selection
If Zelle.Interior.ColorIndex = 3 Then
If ActiveSheet.Cells(Zelle.Row, Zelle.Column - 1).Value <> " " Then
If Not IsEmpty(vntsVariables) Then
ReDim Preserve vntsVariables(UBound(vntsVariables) + 1)
vntsVariables(UBound(vntsVariables)) = ActiveSheet.Cells(Zelle.Row, Zelle.Column - 1).Value
Debug.Print vntsVariables(UBound(vntsVariables))
Else
ReDim vntsVariables(1)
vntsVariables(1) = ActiveSheet.Cells(Zelle.Row, Zelle.Column - 1).Value
Debug.Print ActiveSheet.Cells(Zelle.Row, Zelle.Column - 1).Value
Debug.Print vntsVariables(1)
End If
End If
End If
Next
End With
If Not IsEmpty(vntsVariables) Then
'get folder for pasted data
MsgBox "Bitte geben Sie gewünschten Zielordner für die neuen Dateien an!"
strFolder = GetDirectory() + "\"
intMaxNumRow = 400
stroutputfile = strFolder + "SGN_variables.txt"
strErrorFile = strFolder + "SGN_variables_error.txt"
Debug.Print UBound(vntsVariables)
ReDim strsValues(0 To UBound(vntsVariables))
ReDim strsCheckVariables(UBound(vntsVariables))
strPrint = vntsVariables(0)
For i = 1 To UBound(vntsVariables)
strPrint = strPrint + vbTab + vntsVariables(i)
Next i
nFileNum = FreeFile
Open stroutputfile For Output As #nFileNum
Print #nFileNum, strPrint
Close #nFileNum
nErrorFileNum = FreeFile
Open strErrorFile For Output As #nErrorFileNum
Print #nErrorFileNum, strPrintError
Close #nErrorFileNum
'get folder of files
MsgBox "Bitte geben Sie gewünschten Quellordner an!"
strFolder = GetDirectory() + "\"
Set FSO = CreateObject("Scripting.FileSystemObject")
vntsSubFolders = ListSubFolders(FSO.GetFolder(strFolder), vntsSubFolders)
Application.ScreenUpdating = False
For j = 1 To UBound(vntsSubFolders)
Debug.Print vntsSubFolders(j)
'get folder of files
strFolder = vntsSubFolders(j) + "\"
strDir = vntsSubFolders(j) + "\*.xls"
strFile = Dir(strDir, vbNormal)
Do While strFile <> ""
Debug.Print strFile
Set wb = Excel.Workbooks.Open(strFolder + strFile)
Set ws = wb.Worksheets(1)
ActiveWindow.Visible = False
wb.Protect Structure:=True, Windows:=False
'---------check
For i = 0 To UBound(vntsVariables)
strsCheckVariables(i) = ""
Next i
'---------check
For intNumRow = 1 To intMaxNumRow
For i = 0 To UBound(vntsVariables)
If Replace(ws.Cells(intNumRow, 1).Value, " ", "") = Replace(vntsVariables(i), " ", "") Then
strsCheckVariables(i) = "found"
If Not (IsNull(ws.Cells(intNumRow, 2).Value)) Then
strsValues(i) = ws.Cells(intNumRow, 2)
End If
End If
Next i
Next intNumRow
strPrint = ""
strPrint = strsValues(0)
'---------check
If strsCheckVariables(0) <> "found" Then
Debug.Print "Error in file " + strFile + " :" + vntsVariables(0) + " not found"
Exit Sub
End If
strsValues(0) = ""
'---------check
For i = 1 To UBound(strsValues)
'---------check
If strsCheckVariables(i) <> "found" Then
strErrorPrint = strFile + " :" + vntsVariables(i) + " not found" + vbCrLf
'nFileNum = FreeFile
Open strErrorFile For Append As #nErrorFileNum
Print #nErrorFileNum, strErrorPrint
Close #nErrorFileNum
strPrint = strPrint + vbTab + CStr(strsValues(i))
strsValues(i) = ""
'Exit Sub
'---------check
Else
strPrint = strPrint + vbTab + CStr(strsValues(i))
strsValues(i) = ""
End If
Next i
'nFileNum = FreeFile
Open stroutputfile For Append As #nFileNum
Print #nFileNum, strPrint
Close #nFileNum
wb.Close Savechanges:=False
Set wb = Nothing
Set ws = Nothing
strFile = Dir
Loop
Next j
Application.ScreenUpdating = True
MsgBox "Daten wurden erfolgreich ausgelesen!" & vbNewLine & "Die Datei ist zu finden unter:" & vbNewLine & stroutputfile & vbNewLine & "" & vbNewLine & "Die Fehlerdatei befindet sich im gleichen Ordner!" & vbNewLine & "" & vbNewLine & ":)"
Else
MsgBox "Bitte markieren Sie durch Doppelklick gewünschte Ausgabemerkmale!"
End If
End Sub
Function ListSubFolders(Folder, vntsSubFolders As Variant)
For Each Subfolder In Folder.SubFolders
Debug.Print IsEmpty(vntsSubFolders)
If Not IsEmpty(vntsSubFolders) Then
ReDim Preserve vntsSubFolders(UBound(vntsSubFolders) + 1)
vntsSubFolders(UBound(vntsSubFolders)) = Subfolder.path
'Debug.Print Subfolder.path
vntsSubFolders = ListSubFolders(Subfolder, vntsSubFolders)
Else
ReDim vntsSubFolders(1)
vntsSubFolders(1) = Subfolder
vntsSubFolders = ListSubFolders(Subfolder, vntsSubFolders)
End If
Next
ListSubFolders = vntsSubFolders
End Function
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, X As Long, i As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
X = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(X, path)
If r Then
i = InStr(path, Chr$(0))
GetDirectory = Left(path, i - 1)
Else
GetDirectory = ""
End If
End Function
|