• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Regels verwijderen

Status
Niet open voor verdere reacties.

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..
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:
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan