Semafoor
Gebruiker
- Lid geworden
- 29 aug 2007
- Berichten
- 129
Hallo iedereen.
Ik ben bezig met een soortemet van databse in excel.. Ik heb alleen een probleem met het importeren. Wanneer ik namelijk alle bestanden via vba heb geimporteerd, dan krijg ik een melding dat het maximum is bereikt.. Ik ga zoeken in dat bestand en ontdek dat het vol staat met een soort regel die ik er niet in hoef te hebben.
Nu zoek ik een manier on al die regels automatisch te verwijderen uit dat bestand. Maar.... alle regels hebben een andere zin.. (snap je?)
Ik bedoel dat ze allemaal een woord gelijk hebben en daarna geheel verschillen van elkaar.
Het betreft de zinnen met screensaver. En he zijn er heel veel zonder enig ritme.
Ik heb hier het script dat ik gebruik..
Volgens mij Moet het hier ergens geplaast worden oid..
Is dat mogelijk of niet??
Stefan
Ik ben bezig met een soortemet van databse in excel.. Ik heb alleen een probleem met het importeren. Wanneer ik namelijk alle bestanden via vba heb geimporteerd, dan krijg ik een melding dat het maximum is bereikt.. Ik ga zoeken in dat bestand en ontdek dat het vol staat met een soort regel die ik er niet in hoef te hebben.
Nu zoek ik een manier on al die regels automatisch te verwijderen uit dat bestand. Maar.... alle regels hebben een andere zin.. (snap je?)
Ik bedoel dat ze allemaal een woord gelijk hebben en daarna geheel verschillen van elkaar.
Het betreft de zinnen met screensaver. En he zijn er heel veel zonder enig ritme.
Ik heb hier het script dat ik gebruik..
Code:
Sub ImportMoreFiles()
'Deze code is voor het grootste deel gebaseerd op de voorbeelden in de VBA-Help.
Dim fs As Object
Dim f As Object
Dim f1 As Object
Dim fc As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("C:\Documents and Settings\oomes\Bureaublad\Nieuwe map") 'Echte Path aanpassen aan de realiteit.
Set fc = f.Files
For Each f1 In fc
If UCase(Right(f1.Name, 4)) = ".LOG" Then 'Alleen de .Log files komen in aanmerking.
If Not IsAlreadyImported(f1.Path) Then 'Reeds geïmporteerde files negeren.
Call ImportRange(f1.Path)
End If
End If
Next
End Sub
Sub ImportRange(ByVal cFile As String)
Dim ImpRng As Range
Dim FileName As String
Dim r As Long
Dim c As Integer
Dim txt As String
Dim Char As String * 1
Dim Data
Dim i As Integer
'Set ImpRng = ActiveCell
Set ImpRng = GetFreeCell()
On Error Resume Next
'FileName = ""
FileName = cFile
Open FileName For Input As #1
If Err <> 0 Then
MsgBox "Not Found: " & FileName, vbCritical, "ERROR"
Exit Sub
End If
r = 0
c = 0
txt = " "
Do Until EOF(1)
Line Input #1, Data
For i = 1 To Len(Data)
Char = Mid(Data, i, 1)
If Char = " " Then
'ActiveCell.Offset(r, c) = txt
ImpRng.Offset(r, c) = txt
c = c + 1
txt = " "
ElseIf i = Len(Data) Then
If Char <> Chr(34) Then txt = txt & Char
'ActiveCell.Offset(r, c) = txt
ImpRng.Offset(r, c) = txt
txt = " "
ElseIf Char <> Chr(34) Then
txt = txt & Char
End If
Next i
c = 0
r = r + 1
Loop
Close #1
Call RegisterThisFile(cFile)
End Sub
Private Sub RegisterThisFile(ByVal cFile As String)
Dim oRng As Range, oRow As Range, oC As Range
Set oRng = LastCell(ThisWorkbook.Sheets("Files"))
If oRng Is Nothing Then
ThisWorkbook.Sheets("Files").Cells(1, 1) = cFile
Else
Set oRow = oRng.EntireRow
Set oC = oRow.Cells(1, 1)
oC.Offset(1, 0) = cFile
End If
End Sub
Private Function IsAlreadyImported(ByVal cFile As String) As Boolean
Dim oRng As Range
Set oRng = ThisWorkbook.Sheets("Files").Columns(1).Find(What:=cFile, LookAt:=xlWhole)
IsAlreadyImported = Not (oRng Is Nothing)
End Function
Function GetFreeCell()
Dim oRng As Range, oRow As Range, oC As Range
Set oRng = LastCell(ThisWorkbook.Sheets("Data"))
If oRng Is Nothing Then
Set GetFreeCell = ThisWorkbook.Sheets("Data").Cells(1, 1)
Else
Set oRow = oRng.EntireRow
Set oC = oRow.Cells(1, 1)
Set GetFreeCell = oC.Offset(1, 0)
End If
End Function
Function LastCell(ws As Worksheet) As Range
Dim LastRow&, LastCol%
' Error-handling is here in case there is not any
' data in the worksheet
On Error Resume Next
With ws
' Find the last real row
LastRow& = .Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
' Find the last real column
LastCol% = .Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column
End With
' Finally, initialize a Range object variable for
' the last populated row.
Set LastCell = ws.Cells(LastRow&, LastCol%)
End Function
Volgens mij Moet het hier ergens geplaast worden oid..
Code:
Do Until EOF(1)
Line Input #1, Data
For i = 1 To Len(Data)
Char = Mid(Data, i, 1)
If Char = " " Then
'ActiveCell.Offset(r, c) = txt
ImpRng.Offset(r, c) = txt
c = c + 1
txt = " "
ElseIf i = Len(Data) Then
If Char <> Chr(34) Then txt = txt & Char
'ActiveCell.Offset(r, c) = txt
ImpRng.Offset(r, c) = txt
txt = " "
ElseIf Char <> Chr(34) Then
txt = txt & Char
End If
Is dat mogelijk of niet??
Stefan
Laatst bewerkt: