07. august 2012 - 22:00
Der er
3 kommentarer og
1 løsning
Hente data fra fil2 ind i fil1
Jeg har to excel filer
Den ene indeholder medlemsdata, med medlemsnummeret som id
Den anden indeholder data på kontaktpersoner for medlemmet, men med medlemsnummeret som id
Kan man flette data fra kontaktperson arket ind i medlemsarket.
kontaktperson arket indeholder 2 kontaktpersoner for samme medlem (far & mor) så der skal altså indsættes ekstra kolonner i ark 1 der svarer til fars navn, fars adresse, fars email osv)
Jeg kan ligge arkene online hvis nogen har mod på det
09. august 2012 - 08:57
#4
Rem Fælles
Const startRække = 2
Dim aktuelleSti As String
Rem MedlemsData
Const startKolonneKontaktPersoner = 25
Dim sidsterække As Long, ræk As Long
Dim medlemsNr As Long
Dim arkM As Worksheet, rM As Range
Rem KontaktPersoner
Const kontaktPersonerFilNavn = "kontaktPersoner.xlsx"
Dim kontaktXLS As Object
Dim arkK As Worksheet
Dim antalKrækker As Long, antalKkolonner As Long, rK As Range
Public Sub hentKontaktPersoner()
On Error GoTo lukKontaktPersoner
Application.ScreenUpdating = False
aktuelleSti = opbygAktuelleSti
aktiverKontaktPersoner
aktiverMedlemsArk
sidsterække = ActiveCell.SpecialCells(xlLastCell).Row
For ræk = startRække To sidsterække
medlemsNr = Range("S" & ræk)
findKontaktPersoner medlemsNr, ræk
Next ræk
Application.ScreenUpdating = True
MsgBox "Kørsel afsluttet"
lukKontaktPersoner:
kontaktXLS.Application.Quit
Set kontaktXLS = Nothing
Set arkM = Nothing
End Sub
Private Function opbygAktuelleSti()
Dim sti As String
sti = ThisWorkbook.Path
If Right(sti, 1) <> "\" Then
sti = sti & "\"
End If
opbygAktuelleSti = sti
End Function
Private Sub aktiverKontaktPersoner()
Set kontaktXLS = CreateObject("Excel.Application")
kontaktXLS.Workbooks.Open aktuelleSti & kontaktPersonerFilNavn
Rem Test
Rem kontaktXLS.Visible = True
Set arkK = kontaktXLS.Sheets(1)
antalKrækker = kontaktXLS.ActiveCell.SpecialCells(xlLastCell).Row
antalKkolonner = kontaktXLS.ActiveCell.SpecialCells(xlLastCell).Column
End Sub
Private Sub aktiverMedlemsArk()
Set arkM = ActiveWorkbook.Sheets(1)
End Sub
Private Sub findKontaktPersoner(medlemsNr, ræk)
Dim Kræk As Long, antalMatch As Integer
antalMatch = 0
For Kræk = startRække To antalKrækker
If arkK.Range("A" & Kræk) = medlemsNr Then
antalMatch = antalMatch + 1
Set rK = arkK.Range(arkK.Cells(Kræk, 1), arkK.Cells(Kræk, antalKkolonner))
Set rM = arkM.Cells(ræk, 1).Offset(0, ((antalMatch - 1) * antalKkolonner) + startKolonneKontaktPersoner)
indsætkontaktpersoner rK, rM
End If
Next Kræk
End Sub
Private Sub indsætkontaktpersoner(rK As Range, rM As Range)
rK.Select
rK.Copy
ActiveWorkbook.Activate
rM.Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
