Automatisch waardes uit laten lezen

[sergiodissel]

Ik heb door middel van een code in VBA, een waarde uit een ander bestand te gelezen. Dit is mij nu gelukt om van 1 adres te doen. Ik vroeg mij af of dit ook automatisch voor alle adressen gedaan kan worden. De adressen staan onder elkaar en in kolom F moet de waarde komen te staan die wordt opgezocht. De op te zoeken waarde staat altijd op dezelfde plaats.

Ik heb hierbij deze code gebruikt.

Sub GetDataDemo()

      Dim FilePath$, Row&, Column&, Address$
      
      'change constants & FilePath below to suit
      '***************************************
      Const FileName$ = "TEST.xlsx"
      Const SheetName$ = "Meetbouten zakkingssnelheid"
      Const NumRows& = 7
      Const NumColumns& = 22
      FilePath = Range("D2").Value
      '***************************************
      
      DoEvents
      Application.ScreenUpdating = False
      If Dir(FilePath & FileName) = Empty Then
            MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
            Exit Sub
      End If
      For Row = 7 To NumRows
            For Column = 22 To NumColumns
                  Address = Cells(Row, Column).Address
                  Cells(2, 6) = GetData(FilePath, FileName, SheetName, Address)
                  Columns.AutoFit
            Next Column
      Next Row
      ActiveWindow.DisplayZeros = False
End Sub

Private Function GetData(Path, File, Sheet, Address)
      Dim Data$
      Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & _
            Range(Address).Range("A1").Address(, , xlR1C1)
      GetData = ExecuteExcel4Macro(Data)
End Function

Bijgaand nog een bestandje Bekijk bijlage Voorbeeld.xls

 

[Timshel]

Zo misschien?

Sub tsh()
    Dim Cl As Range
    Dim oFile As Workbook
    
    With ThisWorkbook.Sheets(1)
        For Each Cl In .Range("D2:D" & .Cells(Rows.Count, 4).End(xlUp).Row)
            If Not Dir(Cl.Value) = "" Then
                Set oFile = GetObject(Cl.Value & "TEST.xlsx")
                Cl.Offset(, 2) = oFile.Sheets(1).Cells(7, 22)
                oFile.Close 0
            End If
        Next
    End With
End Sub

 

[sergiodissel]

Top, bedankt! Hij werkt zo. Ik had alleen nog een vraagje: als er geen waarde staat wil ik graag dat er een tekst komt te staan. Hoe doe ik dit?

 

[Timshel]

Als WAAR geen waarde staat wil je WAAR een tekst?

 

[sergiodissel]

Als in cel V7 uit het andere bestand geen waarde staat, wil ik in het huidige bestand een tekst naast het adres, dus kolom F

 

[Timshel]

Voeg een coderegeltje toe.

Sub tsh()
    Dim Cl As Range
    Dim oFile As Workbook
    
    With ThisWorkbook.Sheets(1)
        For Each Cl In .Range("D2:D" & .Cells(Rows.Count, 4).End(xlUp).Row)
            If Not Dir(Cl.Value) = "" Then
                Set oFile = GetObject(Cl.Value & "TEST.xlsx")
                Cl.Offset(, 2) = oFile.Sheets(1).Cells(7, 22)
               [COLOR="#FF0000"] If Cl.Offset(, 2) = "" Then Cl.Offset(, 2) = "All your base are belong to me"[/COLOR]
                oFile.Close 0
            End If
        Next
    End With
End Sub