Makro: Hente data fra andet ark

Ja - det skulle nok kunne lade sig gøre.
De to ark ligger i samme fil og Ark1 er tomt - korrekt?

Rem Koden anbringes i ThisWorkbook
Rem Igangsættes fra VBA (nedenstående Sub F5) eller fra regnearket Alt+F8 - Startopdatering
Rem =======================================================================
Rem For- & Efternavn forudsættes at være i samme celle (ellers giv signal)
rem =======================================================================
Public Sub startOpdatering()
Dim ark, sidsteRæk, ræk
Dim navn, tal
Dim nxtSumræk
    nxtSumræk = 1
   
Rem Slet evt. optælling på SumArk
    clearArk1
   
Rem Gennemgang af Ark2
    ActiveWorkbook.Sheets("Ark2").Activate
    sidsteRæk = ActiveCell.SpecialCells(xlLastCell).Row
    For ræk = 1 To sidsteRæk
        navn = ActiveSheet.Cells(ræk, 1)
        tal = ActiveSheet.Cells(ræk, 2)
               
Rem opdater kun hvis navn er udfyldt
        If navn <> "" Then
            opdaterNavn navn, tal, nxtSumræk
        End If
    Next ræk
   
    ActiveWorkbook.Sheets("Ark1").Activate

    MsgBox ("Opdatering er afsluttet")
End Sub
Private Sub opdaterNavn(navn, tal, nxtSumræk)
Dim sumArk
    Set sumArk = ActiveWorkbook.Sheets("Ark1")
   
    With sumArk.Range("A1:A65000")
        Set c = .Find(navn, LookIn:=xlValues, LookAt:=xlWhole)

        If Not c Is Nothing Then
Rem Navn er fundet
            række = c.Row
            sumArk.Cells(række, 2) = .Cells(række, 2) + tal
        Else
            sumArk.Cells(nxtSumræk, 1) = navn
            sumArk.Cells(nxtSumræk, 2) = tal
           
            nxtSumræk = nxtSumræk + 1
        End If
    End With
End Sub
Private Sub clearArk1()
    ActiveWorkbook.Sheets("Ark1").Activate
    Cells.ClearContents
End Sub

Nej, det er 2 forskellige filer. Den makro jeg har i dag åbner Ark2. Da det tager en krig at åbne Ark2 ville det være lækkert at kunne undgå dette.

Ok - vender tilbage

Version 2:
Rem Koden anbringes i ThisWorkbook i Fil1
Rem Igangsættes fra VBA (nedenstående Sub F5) eller fra regnearket Alt+F8 - Startopdatering
Rem ========================================================================================
Rem De 2 filer forudsættes at ligge i samme mappe
Rem *********************************************
Const kildeFil = "Fil2.xls"                '<---- kan ajf. til rigtige navn
Rem *********************************************
Dim sti, xls2
Public Sub startOpdatering()
Dim ark, sidsteRæk, ræk
Dim navn, tal
Dim nxtSumræk
    nxtSumræk = 1
   
Rem Slet evt. optælling på SumArk
    clearArk1
   
    sti = findSti
    Application.ScreenUpdating = False
   
Rem Åbn Fil2
    Set xls2 = CreateObject("Excel.Application")
    xls2.Workbooks.Open sti + kildeFil
   
Rem Gennemgang af Fil2 - data hentes fra Ark1
    With xls2
        .ActiveWorkbook.Sheets("Ark1").Activate
        sidsteRæk = .ActiveCell.SpecialCells(xlLastCell).Row
        For ræk = 1 To sidsteRæk
            navn = .ActiveSheet.Cells(ræk, 1)
            tal = .ActiveSheet.Cells(ræk, 2)
               
Rem opdater kun hvis navn er udfyldt
            If navn <> "" Then
                opdaterNavn navn, tal, nxtSumræk
            End If
        Next ræk
    End With
   
Rem Luk fil2
    xls2.Application.Quit
    Set xls2 = Nothing
   
    Application.ScreenUpdating = True
    ActiveWorkbook.Sheets("Ark1").Activate
    MsgBox ("Opdatering er afsluttet")
End Sub
Private Sub opdaterNavn(navn, tal, nxtSumræk)
Dim sumArk
    Set sumArk = ActiveWorkbook.Sheets("Ark1")
   
    With sumArk.Range("A1:A65000")
        Set c = .Find(navn, LookIn:=xlValues, LookAt:=xlWhole)

        If Not c Is Nothing Then
Rem Navn er fundet
            række = c.Row
            sumArk.Cells(række, 2) = .Cells(række, 2) + tal
        Else
            sumArk.Cells(nxtSumræk, 1) = navn
            sumArk.Cells(nxtSumræk, 2) = tal
           
            nxtSumræk = nxtSumræk + 1
        End If
    End With
End Sub
Private Sub clearArk1()
    ActiveWorkbook.Sheets("Ark1").Activate
    Cells.ClearContents
End Sub
Private Function findSti()
    findSti = ActiveWorkbook.Path
    If Right(findSti, 1) <> "\" Then
        findSti = findSti + "\"
    End If
End Function

Fantastisk, Kører som en drøm.

Lige et par hurtige spørgsmål.
1)
Når jeg rigtig kommer i gang vil der være flere kolonner som skal ligges sammen. Hvordan tilføjer jeg dette?
Feks. Peter Hansen  2  3  4 etc.

2)
Pt. er navnet i en celle, men kan godt se at jeg bliver nød til at dele det op i 2 celler. Er det muligt?

På forhånd tak
F

0) Lad os først afslutte indeværende - så du får et svar

1) Er der tale et forskelligt antal kolonner pr. navn - med tal?

2) Er navnet i "Fil2" opdelt i 2 kolonner - eller er det i Fil1 navnet ønskes opdelt

1) nej der vil altid være lige mange kolonner, men der kan komme flere til fremover, så det ville være lækkert drlv at kunne tilføje kolonner. Kan vist kun gøres ved at forstå en smule mere af koden end jeg gør nu. :)

Sidder pt på en maskine uden Excel, men dette er mit forsøg?

    With xls2
        .ActiveWorkbook.Sheets("Ark1").Activate
        sidsteRæk = .ActiveCell.SpecialCells(xlLastCell).Row
        For ræk = 1 To sidsteRæk
            navn = .ActiveSheet.Cells(ræk, 1)
            tal = .ActiveSheet.Cells(ræk, 2)
            tal2 = .ActiveSheet.Cells(ræk, 3)               
Rem opdater kun hvis navn er udfyldt
            If navn <> "" Then
                opdaterNavn navn, tal, tal2, nxtSumræk
            End If
        Next ræk
    End With

Private Sub opdaterNavn(navn, tal, tal2, nxtSumræk)
    Set sumArk = ActiveWorkbook.Sheets("Ark1")
   
    With sumArk.Range("A1:A65000")
    With sumArk.Range("A1:A65000")
        Set c = .Find(navn, LookIn:=xlValues, LookAt:=xlWhole)

        If Not c Is Nothing Then
Rem Navn er fundet
            række = c.Row
            sumArk.Cells(række, 2) = .Cells(række, 2) + tal
            sumArk.Cells(række, 3) = .Cells(række, 3) + tal2
        Else
            sumArk.Cells(nxtSumræk, 1) = navn
            sumArk.Cells(nxtSumræk, 2) = tal
           
            nxtSumræk = nxtSumræk + 1
        End If
    End With

2) I begge filer er det 2 kolonner.
Også her vil jeg meget gerne prøve at lære hvad der sker, for den dag vi skal have mellemnavn med vil det være rart selv at kunne det. Dog er jeg helt blank her.

Takker for hjælpen
F

Kommentarer:
1)
          sumArk.Cells(række, 2) = .Cells(række, 2) + tal
            sumArk.Cells(række, 3) = .Cells(række, 3) + tal2  <----a)
        Else
            sumArk.Cells(nxtSumræk, 1) = navn
            sumArk.Cells(nxtSumræk, 2) = tal                  <----b)

a) skal tal ikke optælles i een celle - hvis ikke så OK
b) her skal tal2 også med - denne del er når navn ikke eksistere i forvejen

2) Her ville jeg sætte for- og efternavn (fra Fil2) sammen i en string før der blev foretaget søgning i Fil1.
Men i Fil1 skal der så, når navnet ikke findes - foretages en sammensætning af for- og efternavn og denne indsættes i en kolonne i den relevante række.
Det er så denne kolonne, der skal søges i.

    With sumArk.Range("A1:A65000")          <----dobbelt
    With sumArk.Range("A1:A65000")
        Set c = .Find(navn, LookIn:=xlValues, LookAt:=xlWhole)

d.v.s A skal rettes til den kolonne, der anvendes til det sammensatte navn og i Find
skal skal navn indeholde det sammensatte fra Fil2.

supertekst du er min helt.

Takker mange gange for hjælpen.