Avatar billede kim1a Ekspert
26. september 2016 - 11:11 Der er 2 kommentarer og
1 løsning

Kopiere række fra ark løbende..

Følgende makro er blevet rettet en smule til efter den virkede efter hensigten i spm:
http://www.computerworld.dk/eksperten/spm/1006650

Sub åbne_ark_i_samme_mappe()

' Optimering af åbning og gennemløb
    Dim cal As Integer
    cal = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    ' Definer variable
    Dim wkbMaster As Workbook
    Dim wkbInput As Workbook
    Dim strMappe As String
    Dim strFil As String
    Dim ranRæk As Range
    Dim strLønartID As String
       
    ' Udfyld variable
    Set wkbMaster = ActiveWorkbook
    strMappe = wkbMaster.Names("regnskabsfiler").RefersToRange.Value
    strFil = Dir(strMappe & "\*.*")
    strLønartID = wkbMaster.Sheets("sheet1").Range("B2").Value
     
    Do While strFil <> ""
        ' Laver gennemløb af alle filer i mappen defineret i B1
        Set wkbInput = Workbooks.Open(strMappe & "\" & strFil, False, True)
        ' Kopierer hver linje der i kolonne 6 (f) har samme nr som står i B2 i vognkortfilen
        For Each ranRæk In Range(wkbInput.Worksheets("Workings").Range("A20"), wkbInput.Worksheets("Workings").Range("A1").Offset(wkbInput.Worksheets("workings").Rows.Count - 1, 0).End(xlUp)).Cells
            If ranRæk.Offset(, 5).Value = strLønartID Then
            ranRæk.EntireRow.Copy wkbMaster.Worksheets("Sheets1").Range("A5").Offset(wkbMaster.Worksheets("Sheets1").Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
            End If
        Next
        wkbInput.Close
        strFil = Dir
        Loop
   
    ' Afslut optimering og "almindeliggøre" Excel kalkulationer
    Application.Calculation = cal
    Application.ScreenUpdating = True
End Sub

Min udfordring er at den går i stå hvor ranRæk værdien er "NDS" - det undrer mig meget, jeg ville have troet den var en "adresse", men det kan være jeg har gjort noget galt i udtrykket:
For Each ranRæk In Range(wkbInput.Worksheets("Workings").Range("A20"), wkbInput.Worksheets("Workings").Range("A1").Offset(wkbInput.Worksheets("workings").Rows.Count - 1, 0).End(xlUp)).Cells
            If ranRæk.Offset(, 5).Value = strLønartID Then
            ranRæk.EntireRow.Copy wkbMaster.Worksheets("Sheets1").Range("A5").Offset(wkbMaster.Worksheets("Sheets1").Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
            End If

Kan nogen af jer gennemskue det?
Avatar billede Max_P_Larsen Seniormester
26. september 2016 - 15:56 #1
Hej - det er lidt kompliceret at gennemskue, når man ikke lige sidder med din fil og dine inputdata, så man kan debugge makroen trin for trin. Men jeg forstår også godt, at du nok ikke kan dele filen, da koden tyder på, at den indeholder løndata.

Men ... det ser umiddelbart ud til, at du mangler noget efter ".Copy" - f.eks. noget i stil med "Destination:=wkbMaster.Worksheets("Sheets1")..... " osv., dvs. en angivelse af hvor, det kopierede skal indsættes.

Eller også skal du aktivere det ark, hvori data skal kopieres til og select'e destinationscellen og så ActiveSheet.Paste.

Ved ikke om det løser dit problem men det er mit bedste bud på det foreliggende grundlag.


Mvh Max
Avatar billede eol Praktikant
26. september 2016 - 22:30 #2
Har oplevet lignende før. Løsningen var idiotisk enkel. æø&å kan give problemer.
Jeg ændrede teksten hele vejen igennem - og alt virkede perfekt.'Det kan være simpelt en gang imellem. Dermed ikke sagt at det virker for dig, men det gjorde for mig.
mvh eol
Avatar billede kim1a Ekspert
27. september 2016 - 11:50 #3
Jeres forslag var gode, jeg har dog luret en ændring der fik den til at køre, men nu arbejder den bare virkelig lang tid. Der er 16 ark med ca 10000 linjer i, så muligvis er den så langsom - jeg prøver at lade den stå over natten i dag.

Ændringen er blot sidste
wkbMaster.Worksheets("Sheets1").Range("A5").Offset(wkbMaster.Worksheets("Sheets1").Rows.Count - 1, 0).End(xlUp).Offset(1, 0)

Der skal være A1 i stedet.
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