• 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.

Workbooks koppelen

Status
Niet open voor verdere reacties.

Rabberzzz

Gebruiker
Lid geworden
10 apr 2018
Berichten
59
In middels is het mij gelukt middels VBA om gegevens te exporteren naar een andere worksheet, echter wil ik een koppeling maken naar een ander excel bestand. Alleen heb ik daar graag hulp bij. De bedoeling is dat het andere excel geupdate wordt zonder dat het geopend wordt. Kortom: Knop> exporteren naar andere workbook(totaaloverzicht) zonder visueel te openen > opslaan > sluiten van het document(totaaloverzicht)

Code:
Sub test()

Dim wb As Workbook
Dim Bron_ws As Worksheet
Dim Doel_ws As Worksheet 'Workbook?
Dim Job_ID As Range
Dim Job_descr As Range
Dim Job_status As Range

Dim rij_nr As Double
Dim kolom_nr As Double



Set wb = ActiveWorkbook
Set Bron_ws = wb.Sheets("Sheet1") 'de data vanuit deze sheet moet naar een andere document geexporteerd worden.
Set Doel_ws = wb.Sheets("Totaaloverzicht") 'sheet in het andere document, link nodig naar F:\one drive....
Set Job_ID = Bron_ws.Range("J6") 
Set Job_descr = Bron_ws.Range("K5") 
Set Job_status = Bron_ws.Range("K6") 


Dim Last_R

With Doel_ws 
Last_R = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

Dim R
For R = 2 To Last_R 
If Doel_ws.Cells(R, 1).Value <> "" Then 
If Doel_ws.Cells(R, 1).Value = Job_ID.Value Then 
rij_nr = R 
End If
End If
Next R

With Doel_ws 
    last_c = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With

Dim C
For C = 1 To last_c
If Doel_ws.Cells(1, C).Value <> "" Then 
If Doel_ws.Cells(1, C).Value = Job_descr.Value Then 
kolom_nr = C 
End If
End If
Next C

'Application.ScreenUpdating = False
    'Workbooks.Open Filename:="F:\Onedrive\Sports Labs\Sports Labs EU - Documenten\SPORTS LABS EU\JOB FILES\Test\TOTAALOVERZICHT SPORTSLABS EU.xlsx" dit is wat ik hoopte wat zou werken, maar helaas

Doel_ws.Cells(rij_nr, kolom_nr).Value = Job_status.Value 'Job status overnemen naar doelblad in gevonden rij/kolom

'Windows("F:\Onedrive\Sports Labs\Sports Labs EU - Documenten\SPORTS LABS EU\JOB FILES\Test\TOTAALOVERZICHT SPORTSLABS EU.xlsx").Close
    'Application.ScreenUpdating = True

End Sub
 
Laatst bewerkt:
Wat is de lol om twee keer dezelfde gegevens te hebben ?
 
De lol om extra tijd over te hebben.
Het doel is dat de data naar een overzicht wordt geëxporteerd middels een Button in het werkbare document.
Dan hoef het overzicht niet handmatig geopend te worden en voor elke handeling in het gehele project aangeven of het wel/niet gedaan is.
 
Ligt het niet meer voor de hand om in het doelbestand een koppeling te leggen naar het bronbestand?
 
Ik snap je denkwijze wel. Maar in praktijk werkt het iets anders. Het Bronbestand verandert steeds want het is een template. Het doelbestand blijft wel hetzelfde, alleen de data die geëxporteerd moet worden moet steeds in een specifieke cel geplaatst worden. Dit op basis van een jobnummer. Hopelijk schept het beeld hieronder helderheid?

VBA Push it.jpg
 
Laatst bewerkt:
Zoek eens in de zoekfunktie van Excel op Querytable.
 
Zoek eens in de zoekfunktie van Excel op Querytable.

Ik heb eens zitten snuffelen met jouw geadviseerde zoektermen, alleen vind ik niet iets wat lijkt op wat ik zoek. Veelal wordt de koppeling gemaakt in Acces, terwijl alles in Excel wordt verwerkt.

Daarbij zoek ik enkel een VBA manier dat de werking van de knop niet binnen hetzelfde bestand werkt, maar dat de uitkomst in een ander bestand plaats vindt. Kortom. De werkende code binnen één Excel bestand kunnen wijzigen naar een excel bestand op een andere locatie(locatie van dit bestand veranderd niet).

Als ik verder via google zoek zijn er veel voorbeelden van verwijzingen te vinden, ook naar andere excel bestanden, alleen is dit letterlijk één op één één of meerdere cellen te kopieren waarbij je de locaties copy and to moet aangeven. In mijn geval gaat er een bepaalde loop de sheet van het doelbestand. Alleen krijg ik dit niet veranderd naar het andere bestand.
 
In plaats van een Accessbestand kun je ook gewoon een Excelbestand selecteren om een koppeling mee te leggen.
 
In het linkje staat ook:
Plaats ook een voorbeeld bestand in de vraag, dat helpt met het zoeken naar een oplossing.
en daar wordt geen plaatje mee bedoelt. Van de code in #1 kan ik weinig tabak maken dit komt waarschijnlijk door commentregels die niet kloppen.
 
Bedankt voor het reageren!
De oplossing is echter gevonden.

Zie code hieronder:

Code:
Sub test()

Dim wb As Workbook
Dim wbd As Workbook
Dim Bron_ws As Worksheet
Dim Doel_ws As Worksheet
Dim Job_ID As Range
Dim Job_descr As Range
Dim Job_status As Range

Dim rij_nr As Double
Dim kolom_nr As Double


Set wb = ActiveWorkbook
Set wbd = Workbooks.Open("F:\Onedrive\Sports Labs\Sports Labs EU - Documenten\SPORTS LABS EU\JOB FILES\Test\TOTAALOVERZICHT SPORTSLABS EU.xlsx")
Set Bron_ws = wb.Sheets("Sheet1")
Set Doel_ws = wbd.Sheets("Totaaloverzicht")
Set Job_ID = Bron_ws.Range("J6") 'Job-ID, ingevuld in bron
Set Job_descr = Bron_ws.Range("K5") 'Job omshrijving moet overeenkomen met kolom naam
Set Job_status = Bron_ws.Range("K6") 'Job status mag een vrije tekst zijn, kun je koppelen aan een auto opmaak waardoor je keurig een kleurtje meegeeft aan de cel.


Dim Last_R

With Doel_ws 'Definieert de laatste (gevulde) cel in kolom A, dit om ervoor te zorgen dat je niette veel rijen raadpleegt bij een zoek opdracht.
Last_R = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

Dim R
For R = 2 To Last_R 'sluit de eerste rij uit aangezien daar de kolom kop staat.
If Doel_ws.Cells(R, 1).Value <> "" Then 'als de cel leeg is wordt deze overgeslagen
If Doel_ws.Cells(R, 1).Value = Job_ID.Value Then 'vergelijking tussen Job ID bron en geselecteerde cel op rij = R
rij_nr = R 'Gevonden rij nr vastleggen voor 'later'
End If
End If
Next R

With Doel_ws 'definieert de laatste (gevulde) cel in rij 1, dit om ervoor te zorgen dat je niet teveel kolommen doorloopt bij de zoekopdracht.
    last_c = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With

Dim C
For C = 1 To last_c
If Doel_ws.Cells(1, C).Value <> "" Then 'als de cel leeg is wordt deze overgeslagen
If Doel_ws.Cells(1, C).Value = Job_descr.Value Then 'vergelijking tussen Job descr bron en geselecteerde cel op kolom = R
kolom_nr = C 'Gevonden kolom nr vastleggen voor 'later'
End If
End If
Next C


Doel_ws.Cells(rij_nr, kolom_nr).Value = Job_status.Value 'Job status overnemen naar doelblad in gevonden rij/kolom

wbd.Save
wbd.Close

End Sub
 
Da's mooi. Kan in in een paar regels maar als het werkt dan werkt het.:d
 
Ik heb nog eigenlijk nog een vraag. Nu is het zo dat op deze computer One Drive op station letter F staat en de verwijzing wordt ook gemaakt in de code naar het doelbestand op de F station. Echter kan het maar zo zijn dat de stationsletter op één van de andere apparaten een andere letter is. Is het mogelijk om de code aan te passen dat de stationsletter niet uitmaakt? Of moet de stationsletters van alle andere apparaten worden aangepast naar dezelfde letter?
 

Uitleg hieronder.

Code:
Sub test()

Dim wb As Workbook
Dim wbd As Workbook'[COLOR="#FF0000"]Extra workbook aan te maken, wat het doelbestand moet worden[/COLOR]
Dim Bron_ws As Worksheet
Dim Doel_ws As Worksheet
Dim Job_ID As Range
Dim Job_descr As Range
Dim Job_status As Range

Dim rij_nr As Double
Dim kolom_nr As Double


Set wb = ActiveWorkbook
Set wbd = Workbooks.Open("F:\Onedrive\Sports Labs\Sports Labs EU - Documenten\SPORTS LABS EU\JOB FILES\Test\TOTAALOVERZICHT SPORTSLABS EU.xlsx") '[COLOR="#FF0000"]Te refereren naar het desbetreffende doelbestand[/COLOR]
Set Bron_ws = wb.Sheets("Sheet1")
Set Doel_ws = wbd.Sheets("Totaaloverzicht")'[COLOR="#FF0000"]Het doelbestand die eerder aangemaakt is hier te benoemen inclusief desbetreffende sheet[/COLOR]
Set Job_ID = Bron_ws.Range("J6") 'Job-ID, ingevuld in bron
Set Job_descr = Bron_ws.Range("K5") 'Job omshrijving moet overeenkomen met kolom naam
Set Job_status = Bron_ws.Range("K6") 'Job status mag een vrije tekst zijn, kun je koppelen aan een auto opmaak waardoor je keurig een kleurtje meegeeft aan de cel.


Dim Last_R

With Doel_ws 'Definieert de laatste (gevulde) cel in kolom A, dit om ervoor te zorgen dat je niette veel rijen raadpleegt bij een zoek opdracht.
Last_R = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

Dim R
For R = 2 To Last_R 'sluit de eerste rij uit aangezien daar de kolom kop staat.
If Doel_ws.Cells(R, 1).Value <> "" Then 'als de cel leeg is wordt deze overgeslagen
If Doel_ws.Cells(R, 1).Value = Job_ID.Value Then 'vergelijking tussen Job ID bron en geselecteerde cel op rij = R
rij_nr = R 'Gevonden rij nr vastleggen voor 'later'
End If
End If
Next R

With Doel_ws 'definieert de laatste (gevulde) cel in rij 1, dit om ervoor te zorgen dat je niet teveel kolommen doorloopt bij de zoekopdracht.
    last_c = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With

Dim C
For C = 1 To last_c
If Doel_ws.Cells(1, C).Value <> "" Then 'als de cel leeg is wordt deze overgeslagen
If Doel_ws.Cells(1, C).Value = Job_descr.Value Then 'vergelijking tussen Job descr bron en geselecteerde cel op kolom = R
kolom_nr = C 'Gevonden kolom nr vastleggen voor 'later'
End If
End If
Next C


Doel_ws.Cells(rij_nr, kolom_nr).Value = Job_status.Value 'Job status overnemen naar doelblad in gevonden rij/kolom

wbd.Save '[COLOR="#FF0000"]Door deze regel toe te voegen[/COLOR]
wbd.Close '[COLOR="#FF0000"]Door deze regel toe te voegen[/COLOR]

End Sub
 
Ik zou dit geen koppeling noemen:

Code:
sub M_snb()
   with getobject("F:\Onedrive\Sports Labs\Sports Labs EU - Documenten\SPORTS LABS EU\JOB FILES\Test\TOTAALOVERZICHT SPORTSLABS EU.xlsx")
      sp=.sheets("Sheet1").range("J5:K6")
      .close 0
   end with

   sn = thisworkbook.Sheets("Totaaloverzicht").usedrange

   for j=1 to ubound(sn)
     if sn(j,1)  =sp(2,1) then
       for jj=1 to ubound(sn,2))
          if sn(j,jj)=sp(1,2) then 
            sn(j,jj)=sp(2,2)
            exit for
         end if
       next
       if sn(j,jj)=sp(2,2) then exit for
    end if
  next

  thisworkbook.Sheets("Totaaloverzicht").usedrange=sn
End Sub
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan