Avatar billede Daffodil Professor
14. september 2016 - 14:01 Der er 4 kommentarer og
1 løsning

Opdatere et regneark via en makro fra andet regneark.

Har kastet mig ud i VBA verdenen og lært en masse via spørgsmål og svar her på siden, men jeg er stødt ind i et mindre problem som driller. Jeg har behov for at overskrive nogle adresser i en Excel mappe via en makro der henter data i en anden Excel mappe.

I data Excel mappen er der tre kolonner, hvor søgekriteriet er i kolonne A og data i kolonne B og C. Data fra kolonne B og C skal overføres til den anden Excel mappe.

I destinations Excel mappen er der 7 kolonner hvor søgekriteriet findes i kolonne B og destinationsfelterne er i kolonnerne F og G

Begge Excel mapper har overskrifter. Excel mappen der skal rettes er på over 50000 linjer og der er ca. 100 udsøgningskriterier.
Avatar billede excelent Ekspert
15. september 2016 - 19:39 #1
Prøv test på en kopi :

Sub xOpslag()

Set wb_data = Workbooks("Data_Fil.xlsm").Sheets("Ark1")
Set wb_dest = Workbooks("Dest_Fil.xlsm").Sheets("Ark1")
dest_rk = wb_dest.Cells(Rows.Count, "B").End(xlUp).Row
kilde_rk = wb_dest.Cells(Rows.Count, "B").End(xlUp).Row

For Each c In wb_dest.Range("B2:B" & dest_rk)
  c.Offset(0, 4) = Application.VLookup(c, wb_data.Range("A1:C" & kilde_rk), 2, False)
  c.Offset(0, 5) = Application.VLookup(c, wb_data.Range("A1:C" & kilde_rk), 3, False)
Next

End Sub

Ret navnene i koden på projektmapperne samt evt arknavn til aktuel
Avatar billede Daffodil Professor
16. september 2016 - 07:55 #2
Det virker næsten upåklageligt.

De adresser som ikke skal overskrives bliver erstattet af "#I/T". Den kan jeg simpelthen ikke gennemskue umiddelbart.

Håber det kan klares.
Avatar billede excelent Ekspert
16. september 2016 - 14:47 #3
my bad :-(

Sub xOpslag()

Set wb_data = Workbooks("Data_Fil.xlsm").Sheets("Ark1")
Set wb_dest = Workbooks("Dest_Fil.xlsm").Sheets("Ark1")
dest_rk = wb_dest.Cells(Rows.Count, "B").End(xlUp).Row
kilde_rk = wb_dest.Cells(Rows.Count, "B").End(xlUp).Row

For Each c In wb_dest.Range("B2:B" & dest_rk)
  x1 = Application.VLookup(c, wb_data.Range("A1:C" & kilde_rk), 2, False)
  x2 = Application.VLookup(c, wb_data.Range("A1:C" & kilde_rk), 3, False)
  If IsError(x1) = False Then c.Offset(0, 4) = x1
  If IsError(x2) = False Then c.Offset(0, 5) = x2
Next

End Sub
Avatar billede Daffodil Professor
16. september 2016 - 21:39 #4
Tak for den elegante løsning. Den kører upåklageligt og klarer ca. 50.000 linjer på små 10 sekunder.
Avatar billede excelent Ekspert
17. september 2016 - 13:47 #5
velbekom
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester