VBA - Excel 2013 - Gegevens ophalen van ander Excel-bestand

[jackfish]

Was ik even los gekomen van VBA, ben ik er zo weer mee bezig ;-)

Ik wil een registratieformulier in Excel maken voor registreren van tijd. Op dat formulier moet voor het archiveren de naam, post en personeelsnummer komen. Die gegevens wil ik uit een 2e Excel bestand halen op basis van de username.

Met onderstaande krijg ik het principe voor elkaar maar wordt alleen de naam (en niet de post en personeelsnummer) overgezet. Ik zie niet waar het mis gaat. Wie wel?

    Dim FindString As String
    Dim Username As String
    Dim Rng As Range
    Dim x As Workbook
    Dim y As Workbook
    Dim store As Variant
   
    Set x = Workbooks.Open("H:\Desktop\Username.xlsm")
    Set y = ThisWorkbook
    
    Username = Environ("username")
    FindString = Username
    
    If Trim(FindString) <> "" Then
        With Sheets("Blad1").Range("A:A")
              Set Rng = .Find(What:=FindString, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, 
              SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
              If Not Rng Is Nothing Then
                Application.Goto Rng, True
              Else
                MsgBox "Uw gebruikersnaam is onbekend. Neem contact op met het secretariaat."
              End If
        End With
    End If
    
    ActiveCell.Offset(, 1).Resize(1, 5).Copy
    store = ActiveCell.Offset(, 1).Resize(1, 5).Value
    
    y.Sheets("Blad1").Range("A1").Value = store
    x.Close

 

[snb]

Je hebt geen variabele nodig:

ActiveCell.Offset(, 1).Resize(1, 5).Copy y.Sheets("Blad1").Range("A1").Value

maar zo kan het ook:

  on error resume next
  with Getobject("H:\Desktop\Username.xlsm")
    .Sheets("Blad1").columns(1).Find(environ("Username")).resize(,5).copy thisworkbook.Sheets("Blad1").Range("A1")
    .close 0
  end with
  if err.number<>0 then MsgBox "Uw gebruikersnaam is onbekend. Neem contact op met het secretariaat."

 

[VenA]

Volgens mij klopt er niet veel van het .find gedeelte.

Misschien zo

Sub VenA()
  Dim f As Range
  With GetObject("H:\Desktop\Username.xlsm")
    Set f = .Sheets("Blad1").Columns(1).Find(Environ("username"), , xlValues, xlWhole)
    If Not f Is Nothing Then f.Offset(, 1).Resize(, 5).Copy ThisWorkbook.Sheets("Blad1").Cells(1) Else MsgBox "Uw gebruikersnaam is onbekend. Neem contact op met het secretariaat."
    .Close 0
  End With
End Sub

 

[snb]

@V&A

Heb je de code uit #2 al getest ?

 

[VenA]

Nee, want die is aangepast na mijn reactie.....

Tenzij je weet wat je met de on error resume next afvangt ben ik er niet zo'n voorstander van.

 

[snb]

Lijkt me in dit geval wel duidelijk: 'niet gevonden'