Helpmij.nl
Helpmij.nl
Helpmij.nl
Steun Helpmij.nl! Klik hier     Computerprobleem? Klik hier!

Quote

Weergeven resultaten 1 tot 2 van 2

Onderwerp: Regels verwijderen

  • Vraag is opgelost
  1. #1

    Regels verwijderen

    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 aangepast door Semafoor : 5 september 2007 om 11:32 Reden: code
    "Het gevaar zit hem niet in computers die als mensen gaan denken, maar in mensen die als en computer gaan denken.

    Quote of the Year:If your happy and you know it ..SYNTAX ERROR

  2. #2
    Hoofdmoderator
    Bestuurslid
    crash's avatar
    Geregistreerd
    16 augustus 2001
    Locatie
    Purmerend
    Afstand tot server
    ±105 km
    Je bent in de volgende link ook al met dit probleem bezig, graag daar verder gaan:
    http://www.helpmij.nl/forum/showthread.php?t=312727

    Deze sluit ik.
    grtz Lex

    Op e-mails over computerproblemen reageer ik niet meer, daar is het forum voor.
    16 augustus 2001 - 2011 is tien jaar lid van Helpmij.nl

Berichtenregels

  • U mag geen nieuwe vragen starten.
  • U mag niet reageren op berichten.
  • U mag geen bijlagen versturen.
  • U mag uw berichten niet bewerken.
  •  
Helpmij.nl
Helpmij.nl

Helpmij.nl en business

Partners
Sponsoren
Linkpartners
Aanbiedingen