Avatar billede tvc Seniormester
01. oktober 2016 - 22:49 Der er 10 kommentarer og
1 løsning

VBA flyt posteringer med samme Kontonavn til andet ark med samme navn

Hej

Jeg har brug for at lade en lykke køre igennem en masse posteringer og samle posteringer med samme klassifikationsnavn på samme ark.

Mit ark med posteringer ser således ud:

Konto | Navn | IBeløb | EPBeløb | RBeløb | EBeløb | Mapping

På baggrund af min mapping skal de øvrige felter kopieres over i et ark med navn LS_MappingNavn startende i celle A15.

Vil blive super glad hvis der er en, der kan hjælpe :-)
Avatar billede excelent Ekspert
02. oktober 2016 - 09:38 #1
Prøv på en kopi, det er ikke specielt tydeligt hvad du har hvor

Sub test()
rk = Sheets(1).Cells(65000, "A").End(xlUp).Row
For t = 2 To rk
ark = "LS_" & Cells(t, "G")
rk1 = WorksheetFunction.Max(14, Sheets(ark).Cells(65000, "A").End(xlUp).Row) + 1
Range("A" & t & ":F" & t).Copy Sheets(ark).Cells(rk1, "A")
Next
End Sub
Avatar billede tvc Seniormester
02. oktober 2016 - 12:06 #2
Hej Excelent

Tak for hjælpen. Jeg har rettet den til så den ser sådanne ud:
------------------------------------------------
Sub test()
rk = Sheets("Klassifikation").Cells(65000, "A").End(xlUp).Row
For t = 2 To rk
ark = "LS_" & Cells(t, "G")
rk1 = WorksheetFunction.Max(14, Sheets(ark).Cells(65000, "A").End(xlUp).Row) + 1
Range("A" & t & ":F" & t).Copy Sheets(ark).Cells(rk1, "A")
Next
End Sub
--------------------
Jeg er dog usikker på hvad jeg skal definere rk1 som, da den stopper ved denne linje.

Ellers har du ramt kolonnerne korrekt - selvom jeg ikke havde fået oplyst om dette.

Jeg har ligeledes glemt at fortælle, at IBeløb, EPBeløb, RBeløb, EBeløb er formler, som jeg skal have kopieret over som værdier i format "#.###.##0,00".

Hilsen TVC
Avatar billede excelent Ekspert
02. oktober 2016 - 13:30 #3
prøv :

Sub test2()
Sheets("Klassifikation").Select
rk = Sheets("Klassifikation").Cells(65000, "A").End(xlUp).Row
For t = 2 To rk
ark = "LS_" & Cells(t, "G")
rk1 = WorksheetFunction.Max(14, Sheets(ark).Cells(65000, "A").End(xlUp).Row) + 1
Range("A" & t & ":F" & t).Copy Sheets(ark).Cells(rk1, "A"): Selection = Selection.Value
Sheets(ark).Range("A" & rk1 & ":E" & rk1) = Sheets(ark).Range("A" & rk1 & ":E" & rk1).Value
Sheets(ark).Range("A" & rk1 & ":E" & rk1).NumberFormat = "#,##0.00"
Next
End Sub
Avatar billede tvc Seniormester
02. oktober 2016 - 14:34 #4
Perfekt - Det virker!

Mange tak for hjælpen og god søndag.
Avatar billede tvc Seniormester
03. oktober 2016 - 18:12 #5
Hej excelent

Har jeg fået ændret noget i din oprindelige model nedenfor, der gør at den kopierer område A:F i række t+13 på baggrund af mappingen i kolonne H række t?

Funktionen kopierer ikke tallene i samme række som mappingen står i. Eksempelvis kopierer den A15:G15 i mappingarket og kopierer til LS_&H2

Kan jeg ligeledes ændre Selection = Selection.Value så den indsætter tallene uden formatering?


-------------------------
'Indsæt LS konti

Sheets("Mapping").Select

'Find antal konti i balance
rk = Sheets("Mapping").Cells(65000, "A").End(xlUp).Row

'Kopier hver række i balance til ledig række i LS_mapping
    For t = 2 To rk
       
        'Finder mapping LS
        ark = "LS_" & Cells(t, "H")
           
            'Finder næste ledige række i mapping LS
            rk1 = WorksheetFunction.Max(14, Sheets(ark).Cells(65000, "A").End(xlUp).Row) + 1
       
        'Kopierer mapping række A:G
        Range("A" & t & ":G" & t).Copy Sheets(ark).Cells(rk1, "A"): Selection = Selection.Value
           
        'Konvertering af kopierede data til tal
        Sheets(ark).Range("A" & rk1 & ":G" & rk1) = Sheets(ark).Range("A" & rk1 & ":G" & rk1).Value
               
        'Formaterer LS-række
        Sheets(ark).Range("A" & rk1 & ":A" & rk1).NumberFormat = "#########0"
        Sheets(ark).Range("C" & rk1 & ":G" & rk1).NumberFormat = "#,##0.00"

    Next
Avatar billede tvc Seniormester
03. oktober 2016 - 18:25 #6
Hej igen

Det er linjen:
Range("A" & 2 & ":G" & 2).Copy Sheets(ark).Cells(rk1, "A"): Selection = Selection.Value
Der er årsag til problemet. Den indsætter formlen og ikke tallet. Formlen indeholder en SUM.HVIS på baggrund af kontonummeret.

Hvordan konverterer vi de kopierede data til tal inden de indsættes?
Avatar billede tvc Seniormester
03. oktober 2016 - 18:36 #7
Jeg tror jeg har løst det ved at ændre den til:

'Indsæt LS konti

Sheets("Mapping").Select

'Find antal konti i balance
rk = Sheets("Mapping").Cells(65000, "A").End(xlUp).Row

'Kopier hver række i balance til ledig række i LS_mapping
    For t = 2 To rk
       
        'Finder mapping LS
        ark = "LS_" & Cells(t, "H")
           
            'Finder næste ledige række i mapping LS
            rk1 = WorksheetFunction.Max(14, Sheets(ark).Cells(65000, "A").End(xlUp).Row) + 1
       
        'Kopierer mapping række A:G
        Range("A" & t & ":G" & t).Copy
        Sheets(ark).Cells(rk1, "A").PasteSpecial Paste:=xlPasteValues
           
        'Konvertering af kopierede data til tal
        Sheets(ark).Range("A" & rk1 & ":G" & rk1) = Sheets(ark).Range("A" & rk1 & ":G" & rk1).Value
               
        'Formaterer LS-række
        Sheets(ark).Range("A" & rk1 & ":A" & rk1).NumberFormat = "#########0"
        Sheets(ark).Range("C" & rk1 & ":G" & rk1).NumberFormat = "#,##0.00"

    Next
Avatar billede excelent Ekspert
03. oktober 2016 - 18:39 #8
Den kodelinje kopierer kun række 2 A til G
Formlerne bliver jo konverteret til værdier senere i koden med

Sheets(ark).Range("A" & rk1 & ":G" & rk1) = Sheets(ark).Range("A" & rk1 & ":G" & rk1).Value
Avatar billede tvc Seniormester
03. oktober 2016 - 19:20 #9
Ja men formlernes værdier ændre sig når de kommer over i rækken i LS_arket. Derfor har jeg brug for at de kopierede cellers indhold konverteres til værdier.

Kan man ikke ændre Range("A" & t & ":G" & t).Copy Sheets(ark).Cells(rk1, "A"): Selection = Selection.Value så indholdet allerede her fastlåses til værdier?
Avatar billede excelent Ekspert
03. oktober 2016 - 19:50 #10
Sub test3()
'Indsæt LS konti

Sheets("Mapping").Select

'Find antal konti i balance
rk = Sheets("Mapping").Cells(65000, "A").End(xlUp).Row

'Kopier hver række i balance til ledig række i LS_mapping
For t = 2 To rk
       
'Finder mapping LS
ark = "LS_" & Cells(t, "H")
           
'Finder næste ledige række i mapping LS
rk1 = WorksheetFunction.Max(14, Sheets(ark).Cells(65000, "A").End(xlUp).Row) + 1
       
'Kopierer mapping række A:G
Range("A" & t & ":G" & t).Copy: Sheets(ark).Cells(rk1, "A").PasteSpecial xlPasteValues

'Formaterer LS-række
Sheets(ark).Range("A" & rk1 & ":A" & rk1).NumberFormat = "#########0"
Sheets(ark).Range("C" & rk1 & ":G" & rk1).NumberFormat = "#,##0.00"

Next
End Sub
Avatar billede tvc Seniormester
03. oktober 2016 - 20:14 #11
Nu er den der - tak!
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