Overfør data til flere regneark i samme bibliotek

Prøv denne:

Sub Overfoersel()

Sti = ActiveWorkbook.Path & "\"
Slut = Range("A65536").End(xlUp).Row
Range("A1").Select
For I = 1 To Slut
    For Y = 1 To Slut
        If Range("A" & I + Y).Value <> Range("A" & I).Value Then
            stopher = I + Y - 1
            Exit For
        End If
    Next
    DataRange = Range("A" & I & ":C" & stopher)
    WB = DataRange(1, 1)
    NyWorkbook = Sti & DataRange(1, 1) & ".xls"
    Workbooks.Open Filename:=NyWorkbook
    ActiveWorkbook.Activate
    For N = 1 To UBound(DataRange)
        Sheetnavn = "" & DataRange(N, 2) & ""
        Sheets(Sheetnavn).Select
        SlutNytSheet = Range("A65536").End(xlUp).Row
        Range("A" & SlutNytSheet + 1) = DataRange(N, 3)
    Next
    With ActiveWorkbook
        .Save
        .Close
    End With
    I = I + stopher - 1
Next
End Sub

Der er ikke lavet nogen form for check af tilstedeværelse af regneark og faneblade. Arkene skal ligge i samme folder som dataarket.

En lille ændring:

Sub Overfoersel()
Sti = ActiveWorkbook.Path & "\"
Slut = Range("A65536").End(xlUp).Row
Range("A1").Select
For I = 1 To Slut
    For Y = 1 To Slut
        If Range("A" & I + Y).Value <> Range("A" & I).Value Then
            stopher = I + Y - 1
            Exit For
        End If
    Next
    DataRange = Range("A" & I & ":C" & stopher)
    WB = DataRange(1, 1)
    NyWorkbook = Sti & DataRange(1, 1) & ".xls"
    Workbooks.Open Filename:=NyWorkbook
    ActiveWorkbook.Activate
    For N = 1 To UBound(DataRange)
        Sheetnavn = "" & DataRange(N, 2) & ""
        Sheets(Sheetnavn).Select
        SlutNytSheet = Range("A65536").End(xlUp).Row
        If SlutNytSheet = 1 And Range("A1").Value = "" Then SlutNytSheet = SlutNytSheet - 1
        Range("A" & SlutNytSheet + 1) = DataRange(N, 3)
    Next
    With ActiveWorkbook
        .Save
        .Close
    End With
    I = I + stopher - 1
Next
End Sub

Her er en som er stjålet fra Bak, http://www.eksperten.dk/spm/405469, og modificeret lidt.
Akyhne > den er overhovedet ikke testet for hastighed.
Arkene skal være oprettet i de lukkede excelfiler, og overskriften skal også være der.


Man kan også bruge lidt sql til at indsætte i et lukket regneark.
Husk at sætte reference til microsoft activeX data object

Public Sub WorksheetInsert()
    Dim objConn As ADODB.Connection
    Dim szConnect As String
    Dim szSQL As String
    Dim I As Long
    For I = 2 To Range("B65536").End(xlUp).Row

    ' Opret connection string.
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                "Data Source=" & ThisWorkbook.Path & "\" & Cells(I, 1) & ".xls;" & _
                "Extended Properties=Excel 8.0;"
   
    ' Opret SQL statement, hvor [sales$] er arknavnet efterfulgt af en $.
    szSQL = "INSERT INTO [" & Cells(I, 2) & "$] " & _
            "VALUES(" & Cells(I, 1) & ", " & Cells(I, 2) & ", " & Cells(I, 3) & ")"

    ' Create and open the Connection object.
    Set objConn = New ADODB.Connection
    objConn.Open szConnect
   
    ' Execute the insert statement.
    objConn.Execute szSQL, , adCmdText Or adExecuteNoRecords
   
    ' Close and destroy the Connection object.
    objConn.Close
    Set objConn = Nothing
Next
End Sub

akyhne > vi har vist fat i noget af det rigtige ....

Lige et par ting som mangler :

1 . Koden skulle meget gerne fortsætte hvis der ikke er oprettet et et regneark som findes som Ark ID.

2. Det er kolonne C til H der skal overføres. Kan ikke lige se hvor det indsættes i koden.

3. I de regneark som der overføres data til, findes en rekap - Sheets(1) som laver en totalafstemning for kontogruppen ( eksempelvis 7830 ). I Range("E6") er en kontrol som gerne skulle være 0 ... i givet fald er kontoen afstemt med min balance, og regnearket må gerne lukkes ... ellers skal det forblive åbent ... og ellers fortsætte med næste kontogruppe/kontonummer

C til H??? Det er mere end 3 kolonner

Skal det også overføres til C:something? Skal det ikke markeres i dataarket, hvis dataene ikke overføres?

Hej akyhne >

1. Vha. din programkode, har jeg lavet en lille kontrolrutine som løber alle ark igennem, og prompter brugeren hvis der mangler arkfaner

2. P.t er det kolonne C til H som skal kopieres over

Lidt at arbejde videre med:

Sub Overfoersel()
Dim I As Long, Y As Long, N As Long, Slut As Long, SlutNytSheet As Long
Dim Sti As String, Orignavn As String, WB As String, NyWorkbook As String
Sti = ActiveWorkbook.Path & "\"        'finder stien vi arbejder i
Orignavn = ActiveWorkbook.Name          'Husker navnet på vores data Excelark
Slut = Range("C65536").End(xlUp).Row    'finder ud af hvor langt ned vores data går
For I = 1 To Slut
    For Y = 1 To Slut
        If Range("C" & I + Y).Value <> Range("C" & I).Value Then
            stopher = I + Y - 1        'Skiller arknavne
            Exit For
        End If
    Next
    DataRange = Range("C" & I & ":E" & stopher) 'sætter DataRange til de celler der hører sammen
    WB = DataRange(1, 1)        'Finder ud af hvilket regneark der skal åbnes
    NyWorkbook = Sti & DataRange(1, 1) & ".xls" 'Laver hele stien på filen der skal åbnes
    If Dir(NyWorkbook) <> "" Then              'Checker om Excelfilen eksisterer
        Workbooks.Open Filename:=NyWorkbook    '... og åbner
        ActiveWorkbook.Activate                '..Aktiverer
        For N = 1 To UBound(DataRange)
            Sheetnavn = "" & DataRange(N, 2) & ""  'Sætter navnet på det ark der skal indsættes data i
            Sheets(Sheetnavn).Select                '... og vælger det.
            SlutNytSheet = Range("A65536").End(xlUp).Row 'Finder nederste skrevne celle i kolonne A (hvis det er her der skal skrives)
            If SlutNytSheet = 1 And Range("A1").Value = "" Then SlutNytSheet = SlutNytSheet - 1 'Hvis øverste celle er tom
                Range("A" & SlutNytSheet + 1) = DataRange(N, 3) 'Indsæt data
        Next
        If Sheets(1).Range("E6").Value = 0 Then    'Checker om arket skal gemmes
            With ActiveWorkbook                    '... og gemmer og lukker
                .Save
                .Close
            End With
        End If
        Workbooks(Orignavn).Activate    'Aktivér vores data regneark
    End If
    I = stopher
Next
End Sub

Hov... så ikke du havde puttet noget ind.

Hvad står der i C til H?

Du får lige indhold her :o)

A = Ark ID
B = Finanskontonummer
C = Bogføringsdato ( dd-mm-yyyy )
D = Bilagsnr.
E = Delregnskab kode
F = Tekst
G = Debet
H = Kredit

Sub Overfoersel()
Dim I As Long, Y As Long, N As Long, Slut As Long, SlutNytSheet As Long
Dim Sti As String, Orignavn As String, wb As String, NyWorkbook As String
Dim wbAabnet As Workbook, Aabnet As Boolean
Sti = ActiveWorkbook.Path & "\"        'finder stien vi arbejder i
Orignavn = ActiveWorkbook.Name          'Husker navnet på vores data Excelark
Slut = Range("A65536").End(xlUp).Row    'finder ud af hvor langt ned vores data går
For I = 1 To Slut
    For Y = 1 To Slut
        If Range("A" & I + Y).Value <> Range("A" & I).Value Then
            stopher = I + Y - 1        'Skiller arknavne
            Exit For
        End If
    Next
    DataRange = Range("A" & I & ":H" & stopher) 'sætter DataRange til de celler der hører sammen
    wb = DataRange(1, 1)        'Finder ud af hvilket regneark der skal åbnes
    NyWorkbook = Sti & DataRange(1, 1) & ".xls" 'Laver hele stien på filen der skal åbnes
    Succes = 1
    If Dir(NyWorkbook) <> "" Then              'Checker om Excelfilen eksisterer
        Aabnet = False
        For Each wbAabnet In Application.Workbooks
            If wbAabnet.Name = DataRange(1, 1) & ".xls" Then
                Aabnet = True
            End If
        Next
        If Aabnet = False Then
            Workbooks.Open Filename:=NyWorkbook    '... og åbner
        Else
            Windows(DataRange(1, 1) & ".xls").Activate
        End If
        ActiveWorkbook.Activate                '..Aktiverer
        For N = 1 To UBound(DataRange)
            Sheetnavn = "" & DataRange(N, 2) & ""  'Sætter navnet på det ark der skal indsættes data i
            Sheets(Sheetnavn).Select                '... og vælger det.
            SlutNytSheet = Range("A65536").End(xlUp).Row 'Finder nederste skrevne celle i kolonne A (hvis det er her der skal skrives)
            If SlutNytSheet = 1 And Range("A1").Value = "" Then SlutNytSheet = SlutNytSheet - 1 'Hvis øverste celle er tom
                For Skriv = 0 To 5
                    Cells(SlutNytSheet + 1, Skriv + 1) = DataRange(N, 3 + Skriv)  'Indsæt data
                    Succes = 2
                Next
        Next
        If Sheets(1).Range("E6").Value = 0 Then    'Checker om arket skal gemmes
            With ActiveWorkbook                    '... og gemmer og lukker
                .Save
                .Close
            End With
            Succes = 3
        End If
        Workbooks(Orignavn).Activate    'Aktivér vores data regneark
        Range("A" & I & ":H" & stopher).Select
        With Selection.Interior
            If Succes = 2 Then
                .ColorIndex = 36
            Else
                If Succes = 3 Then
                    .ColorIndex = 35
                End If
            End If
        End With
    Else
        Range("A" & I & ":H" & stopher).Select
        With Selection.Interior
            .ColorIndex = 3
        End With
    End If
    I = stopher
Next
End Sub

Skal der være kolonneoverskrifter der hvor der kopieres/eksporteres fra ?

???

If Sheets(1).Range("E6").Value = 0 Then    'Checker om arket skal gemmes

!!! regnearket lukkes uanset ovennævnte kontrol ????

Fandt selv ud af, at kolonneoverskrifterne skal udelades :o)

Så hedder dit kontrolark ikke Sheets(1). Det var bedre hvis du havde et navn at gå efter.

Hvad hedder fanebladet(sheet). Hedder det rekap?

Ok. Excel tager ikke for fejl 40 - hverken dine eller mine ;-)

Arkfanen identificeres i DataRange(1, 1), men denne variant fejler :o(

If Sheets(DataRange(1, 1)).Range("E6").Value = 0 Then    'Checker om arket skal gemmes

Fejler. hvordan?

Subscript out of range
Stopper på den pågældende linie

Det er korrekt arkfane den identificerer ved debug, eneste ændring er, at værdien 0 ikke er E6, men derimod E15 ... ( dette har jeg taget højde for i linien ), men er der andre steder hvor E6 skal rettes til E15 ????

Der skulle også stå

If Sheets(1).Range("E6").Value = 0 Then    'Checker om arket skal gemmes

Eller har jeg misforstået hvilket ark du checker i?

Systematikken / fremgangsmåden er følgende :

I celle E6 summeres alle underliggende arksummer ( transaktionsdata på kontoniveau )
I celle E10 aflæses balancesummen på kontogruppen ( Ark ID )
I celle E15 er den E6 - E10 som gerne skulle give 0, hvorefter balancesummen er afstemt med enkelttransaktionerne, og regnearket lukkes automatisk.

Hvis celle E15 er forskellig fra 0, skal kontoen afstemmes manuelt af bruger, hvorfor arket ikke skal lukkes ... ( programrutinen fortsætter til næste kontogruppe )

Det gør den også, bare på E6. Hvorfor havde du ændret linien til "If Sheets(DataRange(1, 1)).Range("E6").Value = 0 Then    'Checker om arket skal gemmes"?

Det var på baggrund af din kommentar 26/09-2006 09:31:11

Uanset om Celle E6 er 0 eller ej, skal arket altid gemmes, men det skal ikke lukkes hvis igen, hvis den ikke er 0

Gemmer, men lukker ike altid - ikke checket, er på vej ud af døren!!!

        With ActiveWorkbook                    '... og gemmer og lukker
              .Save
              If Sheets(1).Range("E6").Value = 0 Then    'Checker om arket skal gemmes
                .Close
                Succes = 3
              end if
            End With
        End If

Kom du videre?

Nej :-(  uanset hvad, så gemmer og lukker den alle regneark

Hvad hedder fanebladet hvor der skal checkes?

For den pågældende kontogruppe hedder der 7821 ... svarende til den værdi der identificeres i DataRange(1, 1)

Var det nemmere hvis jeg sendte modellen til dig ?

Det må du gerne - sende.
gt4 at racingcar punkt dk

Så arket hedder 7821.xls, indeholder et faneblad der hedder 7821, og nogen der hedder 7821001, 7821002 o.s.v.?

Ja ... korrekt for det ene ark, men eksempelvis 7172.xls for næste o.s.v.

hvordan afkoder jeg din mail ?

at = @, punkt = .

Sendt

Så skulle den være der:


Sub OverfoerData()

Dim I As Long, Y As Long, N As Long, Slut As Long, SlutNytSheet As Long
Dim Sti As String, Orignavn As String, wb As String, NyWorkbook As String, AfstemtNavn
Dim wbAabnet As Workbook, Aabnet As Boolean

Sti = ActiveWorkbook.Path & "\"        'finder stien vi arbejder i
Orignavn = ActiveWorkbook.Name          'Husker navnet på vores data Excelark

Slut = Range("A65536").End(xlUp).Row    'finder ud af hvor langt ned vores data går

    For I = 1 To Slut
    For Y = 1 To Slut
        If Range("A" & I + Y).Value <> Range("A" & I).Value Then
            stopher = I + Y - 1        'Skiller arknavne
            Exit For
        End If
    Next
   
    DataRange = Range("A" & I & ":H" & stopher) 'sætter DataRange til de celler der hører sammen
    wb = DataRange(1, 1)        'Finder ud af hvilket regneark der skal åbnes
    NyWorkbook = Sti & DataRange(1, 1) & ".xls" 'Laver hele stien på filen der skal åbnes
    Succes = 1
    If Dir(NyWorkbook) <> "" Then              'Checker om Excelfilen eksisterer
        Aabnet = False
        For Each wbAabnet In Application.Workbooks
            If wbAabnet.Name = DataRange(1, 1) & ".xls" Then
                Aabnet = True
            End If
        Next
        If Aabnet = False Then
            Workbooks.Open Filename:=NyWorkbook    '... og åbner
        Else
            Windows(DataRange(1, 1) & ".xls").Activate
        End If
        AfstemtNavn = "" & DataRange(1, 1) & ""
        ActiveWorkbook.Activate                '..Aktiverer
        For N = 1 To UBound(DataRange)
            Sheetnavn = "" & DataRange(N, 2) & ""  'Sætter navnet på det ark der skal indsættes data i
            Sheets(Sheetnavn).Select                '... og vælger det.
            SlutNytSheet = Range("A65536").End(xlUp).Row 'Finder nederste skrevne celle i kolonne A (hvis det er her der skal skrives)
            If SlutNytSheet = 1 And Range("A1").Value = "" Then SlutNytSheet = SlutNytSheet - 1 'Hvis øverste celle er tom
                For Skriv = 0 To 5
                    Cells(SlutNytSheet + 1, Skriv + 1) = DataRange(N, 3 + Skriv)  'Indsæt data
                    Succes = 2  'overført
                Next
        Next
        With ActiveWorkbook                    '... og gemmer og lukker
            .Save
            If Sheets(AfstemtNavn).Range("E15").Value = 0 Then  'Checker om arket skal gemmes
                .Close
                Succes = 3      'gemt
            End If
        End With
       
        Workbooks(Orignavn).Activate    'Aktivér vores data regneark
        Range("A" & I & ":H" & stopher).Select
        With Selection.Interior
            If Succes = 2 Then
                .ColorIndex = 36        'sætter gul farve på data der er overført
            Else
                If Succes = 3 Then
                    .ColorIndex = 35    'sætter grøn farve på data der er overført og gemt
                End If
            End If
        End With
    Else
        Range("A" & I & ":H" & stopher).Select
        With Selection.Interior
            .ColorIndex = 3        'sætter rød farve på data der ikke blev overført
        End With
    End If
    I = stopher
Next

End Sub

Det var da bare lige det der skulle til :o) .... kiggede du også lige på kontocheck rutinen ????

Jeg er på vej hjemad, men er igen at træffe i morgen :o) ... foreløbig mange mange tak

Kigger på det. Læste først lige hele din mail for kort tid siden.

Ok :o)

Super løsning :o) ... læg svar

Et svar :-)