08. juli 2015 - 06:49Der er
4 kommentarer og 1 løsning
Overfør data fra et regneark til et andet via makro
Hej jeg har brug for noget hjælp til at lave en makro.
Det den skal kunne gøre er som følgende:
I regneark produkt er der data i følgende celler
Fx i celle A2 står produkt-id fx 50 så der data i celle E5, E7, E9, E11, E13 og E15
Jeg ønsker at når man køre makroen i regneark produkt, så åbner den regneark datasamler og søger i A kolonnen efter produkt-id, og når den finder den række hvor produkt-id står i, så udfylder den rækken med data fra produkt regnearket. så kolonnen B=E5, C=E7, D=E9 osv.
Rem VBA koden anbringes under Ark1 I filen Produkt Rem HøjreKlik på ProduktId i A2 for at udføre "dataoverførelsen" Rem Hvis ønskeligt kan du få filerne. @-adresse under min profil
Dim produkt As Object
Const dataSamlerSti = "C:\Users\peter\Desktop\Eksp_IT-rookie_080715\" '<---- tilpasses Const dataSamlerFilNavn = "Datasamler.xlsx" '<---- - " - Dim dataSamler As Object Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Dim produktId, rækDs As Integer Set produkt = ActiveWorkbook
If Target.Address = "$A$2" Then Cancel = True
produktId = Target
Set dataSamler = CreateObject("Excel.Application") dataSamler.Workbooks.Open dataSamlerSti & dataSamlerFilNavn
rækDs = findRækkeDataSamler(produktId) If rækDs > 0 Then kopierData rækDs dataSamler.ActiveWorkbook.Save Else MsgBox "ProduktId ikke fundet" End If End If dataSamler.Quit Set dataSamler = Nothing End Sub Private Function findRækkeDataSamler(produktId) Dim antalRækker As Integer antalRækker = dataSamler.ActiveCell.SpecialCells(xlLastCell).Row
With dataSamler.Sheets(1) dataSamler.Sheets(1).Activate
For Each cc In .Range("A2:A" & antalRækker) If produktId = cc Then findRækkeDataSamler = cc.Row Exit Function End If Next cc End With findRækkeDataSamler = 0 End Function Private Sub kopierData(rækDs) With dataSamler.Sheets(1) .Range("B" & rækDs) = produkt.Sheets(1).Range("E5") .Range("C" & rækDs) = produkt.Sheets(1).Range("E7") .Range("D" & rækDs) = produkt.Sheets(1).Range("E9") .Range("E" & rækDs) = produkt.Sheets(1).Range("E11") .Range("F" & rækDs) = produkt.Sheets(1).Range("E13") .Range("G" & rækDs) = produkt.Sheets(1).Range("E15") End With End Sub
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.