Hente data i en ekstern fil - fortsat

Dette er en direkte fortsættelse af:

http://www.eksperten.dk/spm/796563

som punkt 3 kunne man også bare indsætte de affotograferede informationer /hele linien / kolonnerne a-o.

Ganske enkelt overskrive efter importen er udført.

Må de nye linjer sættes nederst ??

bliver kontoplan.xls opdateret med værdier, så der er flere at hente ?

Det hurtigste er at overskrive alle, i stedet for at tilføje.

Nej.
Kontoplan.xls er statisk, som udgangspunkt.

Det er i det enkelte ark som får importeret data det bliver tilføjet data til i kolonnerne g+j+n+o.

Jeg tror ikke at det er godt de bliver tilføjet under.
Da det giver problemer når makroen "dan_regnskab_specifikationer" køres.

Det er fordi arket Import tit ændrer sig, således at der kommer nye numre til.

hvad med en sortering på kontonummer, efter at de er tilføjet nederst ??

koderne i de nævnte kolonner fortæller bl.a hvilket specifikationsnr kontoen hører til.
Dette er individuelt fra fil til fil.

Filen "kontoplan.xls" forslår en kode første gang linien importeres, men det sker tit at koderne i disse kolonner ændres. Det er ikke en generel ændring men kun en ændring der vedrører netop denne fil

Det kunne godt være en løsning tror jeg.
Er lidt spændt på om en af de andre makroer kan kapere det.
Men det er bestemt et forsøg værd

prøv at teste:


Public Sub HentKonto()
    Dim Data As Variant, Data1 As Variant, Poster() As Variant, I As Long, X As Integer, Tjekdata As Variant
    Dim Antal As Long, K As Long, kildeSti As String, OK As Boolean
    Dim kXLS As Application, SH As Worksheet
    Application.ScreenUpdating = False

    ' Åbner kontoplan og henter data fra arket konto
    Set kXLS = CreateObject("Excel.application")
    kildeSti = "C:\Test\KONTOPLAN.xls"    ' ret den til hvor din konto ligger
    With kXLS
        .Workbooks.Open kildeSti

        With .Sheets("Konto")
            .Activate

            rw = .Range("A7000").End(xlUp).Row + 1
            Data = .Range("A5:O" & rw)    ' variabel med tal
            Data1 = .Range("A5:O" & rw).Formula    ' variabel med formler

        End With
        .ActiveWorkbook.Close
        .Application.Quit    ' lukker den excel, der blev åbnet for at læse data
        Set kXLS = Nothing
    End With

    ' gemmer i den excelmappe som koden er i og det valgte ark
    Tjekdata = Worksheets("Import").Range("A2:c" & Worksheets("Import").Range("A7000").End(xlUp).Row)
    Tjekdata1 = Worksheets("ark1").Range("A2:A" & Worksheets("ark1").Range("A7000").End(xlUp).Row)


    Antal = UBound(Data, 1)
    'On Error Resume Next
    For I = 1 To UBound(Data, 1)
        OK = False
        If Not IsEmpty(Data(I, 1)) Then

            For X = 1 To UBound(Tjekdata, 1)
                If Tjekdata(X, 1) <> 0 Then
                    If Data(I, 1) = Tjekdata(X, 1) And Not IsEmpty(Tjekdata(X, 3)) Then
                        OK = True
                        Exit For
                    End If
                End If
            Next

            If OK Then
                For X = 1 To UBound(Tjekdata1, 1)
                    If Data(I, 1) = Tjekdata1(X, 1) And Not IsEmpty(Tjekdata1(X, 1)) Then
                        OK = False
                        Exit For
                    End If
                Next
            End If

        End If

        If Not OK Then
            Data(I, 1) = Empty
            Antal = Antal - 1
        End If

    Next
    ReDim Poster(Antal, UBound(Data, 2) - 1)
    K = 0
   
    With Worksheets("ark1")    ' ret til det ark du vil have det i
        rw = .Range("A7000").End(xlUp).Row + 1
        If rw < 5 Then rw = 5
        For I = 1 To UBound(Data, 1)
            If Not IsEmpty(Data(I, 1)) Then
                For X = 1 To UBound(Data, 2) - 1
                    Poster(K, X - 1) = Replace(Data1(I, X), I + 4, K + rw)

                Next
                K = K + 1
            End If
        Next



        .Range("A" & rw).Resize(UBound(Poster, 1), UBound(Poster, 2)) = Poster
        Range("A5").Select
    .Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Sort Key1:=Range("A5"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        .Range("A5").Select
    End With
   
    Application.ScreenUpdating = True
End Sub

Surt, jeg lukkede pcen 2 min. før du skrev den sidste besked. :-)

Jeg har testet og får fejl i følgende linie:
.Range("A" & rw).Resize(UBound(Poster, 1), UBound(Poster, 2)) = Poster

ark1 er om døbt til "konto" hos mig.

Hvis jeg opretter ark1 virker den 1 gang. 2. gang går det galt med ovenstående kode.

Er de så ikke fordi den ikke har nogen nye poster at tilføje.
Jeg forklarer lige koden.
1.
Den tager alle konti med, som er i arket "Import", der har et kontonummer og der er skrevet noget i C kolonnen.
2.
Den tjekker "ark1" om de er der i forvejen, hvis der er hentes de ikke.

3.
ved tilføjelse, sættes de nye i bunden og der foretages en sortering.

4. angående fejlen, kan du prøve at erstatte

    Next
    ReDim Poster(Antal, UBound(Data, 2) - 1)
    K = 0

med

  Next
if antal = 0 then msgbox"Ingen data tilføjet" : exit sub
ReDim Poster(Antal, UBound(Data, 2) - 1)
    K = 0

Yes, nu virker den lige som den skal.
Super.
Den er tilmed hurtig.

Jeg takker mange gange...endnu engang. :-)

Hvis du lige giver mig et svar er pointene dine.

et svar ;-))

Lige et lille tillægsspørgsmål:

Hvis du kører makroen dan_regnskab_specifikation (i moduler dan_Regnskab_specifikationer) er den rimelig hurtig første gang.
Men alle de efterfølgende gange er den mindste dobbelt så lang tid om det.

Jeg kører 2007 og det er MEGET langsommere end excel 2003 og kan derfor godt være et irrititationsmoment.

Er der nogen grund til at den bliver langsommere fra 2. gang.?

Jeg opretter gerne et nyt spørgsmål med point på dette!!!!

Angående fejl i formel

Ret
  Poster(K, X - 1) = Replace(Data1(I, X), I + 4, K + rw)

til

    Poster(K, X - 1) = Replace(Replace(Data1(I, X), "A" & I + 4, "A" & K + rw), "G" & I + 4, "G" & K + rw)

mere rettelse

Public Sub HentKontoplan_ekstern()
    Dim Data As Variant, Data1 As Variant, Poster() As Variant, I As Long, X As Integer, Tjekdata As Variant
    Dim Antal As Long, K As Long, kildeSti As String, OK As Boolean, Y As Integer, AD As Variant
    Dim kXLS As Application, SH As Worksheet, TempPost As String
    Application.ScreenUpdating = False

    ' Åbner kontoplan og henter data fra arket konto
    Set kXLS = CreateObject("Excel.application")
    kildeSti = "C:\data\KONTOPLAN.xls"    ' ret den til hvor din konto ligger
    With kXLS
        .Workbooks.Open kildeSti

        With .Sheets("Konto")
            .Activate

            rw = .Range("A7000").End(xlUp).Row + 1
            Data = .Range("A5:O" & rw)    ' variabel med tal
            Data1 = .Range("A5:O" & rw).Formula    ' variabel med formler

        End With
        .ActiveWorkbook.Close False
        .Application.Quit    ' lukker den excel, der blev åbnet for at læse data
        Set kXLS = Nothing
    End With

    ' gemmer i den excelmappe som koden er i og det valgte ark
    Tjekdata = Worksheets("Import").Range("A2:c" & Worksheets("Import").Range("A7000").End(xlUp).Row)
    Tjekdata1 = Worksheets("ark1").Range("A2:A" & Worksheets("ark1").Range("A7000").End(xlUp).Row)


    Antal = UBound(Data, 1)
    'On Error Resume Next
    For I = 1 To UBound(Data, 1)
        OK = False
        If Not IsEmpty(Data(I, 1)) Then

            For X = 1 To UBound(Tjekdata, 1)
                If Tjekdata(X, 1) <> 0 Then
                    If Data(I, 1) = Tjekdata(X, 1) And Not IsEmpty(Tjekdata(X, 3)) Then
                        OK = True
                        Exit For
                    End If
                End If
            Next

            If OK Then
                For X = 1 To UBound(Tjekdata1, 1)
                    If Data(I, 1) = Tjekdata1(X, 1) And Not IsEmpty(Tjekdata1(X, 1)) Then
                        OK = False
                        Exit For
                    End If
                Next
            End If

        End If

        If Not OK Then
            Data(I, 1) = Empty
            Antal = Antal - 1
        End If

    Next
    If Antal = 0 Then Exit Sub
    ' MsgBox "Ingen data tilføjet":
    ReDim Poster(Antal, UBound(Data, 2) - 1)
    K = 0

    With Worksheets("ark1")    ' ret til det ark du vil have det i
        rw = .Range("A7000").End(xlUp).Row + 1
        If rw < 5 Then rw = 5
        For I = 1 To UBound(Data, 1)
            If Not IsEmpty(Data(I, 1)) Then
                For X = 1 To UBound(Data, 2) - 1
                    'Adresser der skal ændres rækker for er "A","C", "E","G","Q" og "J"
                    AD = Array("A", "C", "E", "G", "Q", "J")
                    TempPost = Data1(I, X)
                    For Y = 0 To UBound(AD)
                        TempPost = Replace(TempPost, AD(Y) & I + 4, AD(Y) & K + rw)
                        Poster(K, X - 1) = TempPost
                    Next
                Next
                K = K + 1
            End If
        Next



        .Range("A" & rw).Resize(UBound(Poster, 1), UBound(Poster, 2)) = Poster
        Range("A5").Select
        .Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
        Selection.Sort Key1:=Range("A5"), Order1:=xlAscending, Header:=xlGuess, _
                      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                      DataOption1:=xlSortNormal
        .Range("A5").Select
    End With

    Application.ScreenUpdating = True
End Sub