Print side | Luk vindue

Automatisk generering af felter (blok)

Udskrevet fra: Dansk Regneark Forum
Kategori: Hjælp til regneark.
Forum navn: Makro og VBA
Forum beskrivelse: Hjælp til Makroer og VBA-programmering
Web-adresse: https://forum.excel-regneark.dk/forum_posts.asp?TID=827
Udskrevet den: 18.Maj.2024 kl. 01:10


Emne: Automatisk generering af felter (blok)
Besked fra: A.Larsen
Emne: Automatisk generering af felter (blok)
Posteringsdato: 04.Jul.2012 kl. 10:26
Hej
 
Jeg har aldrig arbejdet med VBA, men har fået at vide, at følgende problem skal løses via VBA:
 
Jeg har et regneark med to faner. I fane to er der 18 rækker og 6 kolonner, hvori der er tekst og tal. Denne "blok" skal jeg have automatisk overført til fane 1 (redigerbart), MEN ud fra den funktion, at man i fane 1 indskriver et tal i fx A1. Dette tal skal angive, hvor mange gange denne "blok" skal forekomme.
 
Dvs. hvis man i A1 skriver 1, så kommer de 18 rækker og 6 koloner én gang. Skriver man 5, vil "blokken" komme fem gange efter hinaden, dvs. 5*18 = 90 rækker med de 6 kolonner.
 
Hvordan gør jeg dette lettest?
 
Mvh
Alexander, som er yderst nybegynder til VBA Smile  


Svar:
Besked fra: Max Mortimer
Posteringsdato: 28.Jul.2012 kl. 23:32
Hej Alexander,

Jeg har vedhæftet et regneark, som burde løse dit problem på elegant vis.
/uploads/603/kopierData.xlsm">uploads/603/kopierData.xlsm

For andre interesserede har jeg pastet koden her:

Private Sub btnKopier_Click()

    Dim wsOprindelig        As Worksheet
    Dim wsDestination       As Worksheet
    Dim rOprindelig         As Range
    Dim rDestination        As Range
    Dim iNumber             As Integer
    Dim i                   As Integer
    
    Set wsOprindelig = ThisWorkbook.Sheets("Oprindelig")
    Set wsDestination = ThisWorkbook.Sheets("Destination")
    
    '// Ryd indholdet på destinationssiden
    wsDestination.Cells.Clear
    
    '// Sæt "arealet" af det, der skal flyttes.
    '// På denne måde bliver det automatisk indstillet
    With wsOprindelig
        Set rOprindelig = .Range(.Range("A1"), _
        .Cells(.Range("A1").End(xlDown).Row, .Range("A1").End(xlToRight).Column))
        ' Alternativ:  Set rOprindelig = wsOprindelig.Range("A1:F18")
        ' (Hvis du er sikker på, at arealet kun er 6 x 18)
        
        '// Antal gange feltet skal kopieres (hentes fra celle A1)
        On Error Resume Next
        iNumber = CInt(.Range("A1"))
        If Err.Number > 0 Then iNumber = 1
        On Error GoTo 0
        
    End With
     
    '// Destination:
    With wsDestination
    
        Set rDestination = .Range(.Range("A1"), .Cells(rOprindelig.Rows.Count, rOprindelig.Columns.Count))
    
        '// Her bruger vi en løkke til at kopiere arealet det antal gange, vi ønsker.
        For i = 1 To iNumber
            
            '// Overfør data til den anden fane
            rDestination.Value = rOprindelig.Value
            
            '// Sæt det næste punkt
            Set rDestination = .Range(.Cells(.Rows.Count, 1).End(xlUp).Offset(1), _
            .Cells(rOprindelig.Rows.Count + rDestination.Rows.Count * i, _
            rOprindelig.Columns.Count))
            
        Next i
    
    End With
    
    '// Frigør hukommelse
    Set rDestination = Nothing
    Set rOprindelig = Nothing
    Set wsOprindelig = Nothing
    Set wsDestination = Nothing

End Sub

Besked fra: A.Larsen
Posteringsdato: 29.Jul.2012 kl. 22:14
Mange tak for koden :)
 
Jeg har dog allerede fået genereret en kode til at gøre det, dog er min kode en del længere.
 
Næste gang jeg får tid, vil jeg afprøve din kode
 
Mvh
Alexander


Print side | Luk vindue