Kopieren van 1 sheet naar een 2de sheet

[Rommyke]

Hoi allemaal ,

Ik heb 2 sheets in mijn excel file.

Mijnn eerste sheet wil ik gebruiken voor de input waarbij ik de data kan kontroleren .
En met een knop schrijf ik deze weg naar een 2de sheet in een tabel vorm.

Ik heb volgende codes gemaakt hiervoor.

Code om input blad (Sheet1) leeg te maken

Sub ClearCells()

Dim Rng1            As Range
Dim Rng2            As Range
Dim Rng3            As Range
Dim Rng4            As Range
Dim Rng5            As Range
Dim DelRange        As Range
Dim MergeRange()    As String
Dim Cel             As Range
Dim i               As Long


    Set Rng1 = Range("E4:H4")
    Set Rng2 = Range("O3:R7")
    Set Rng3 = Range("L11:M12")
    Set Rng4 = Range("L15:M16")
    Set Rng5 = Range("L22:O39")
    
    Set DelRange = Union(Rng1, Rng2, Rng3, Rng4, Rng5)
    
    For Each Cel In DelRange
        If Cel.MergeArea.Cells.Count > 1 Then
            i = i + 1
            ReDim Preserve MergeRange(1 To i)
            MergeRange(i) = Cel.MergeArea.Address
            Cel.MergeArea.UnMerge
        End If
    Next
    
    DelRange.ClearContents
    
    If i > 0 Then
        For i = 1 To UBound(MergeRange)
            Range(MergeRange(i)).Merge
        Next i
    End If
End Sub

En de volgende code om te kopieren .

Option Explicit
Dim LastRow As Integer
Sub Bewaar_Input()
Dim TotaalVoorasEerst As Integer
Dim TotaalVoorasNu As Integer
Dim TotaalAchterasEerst As Integer
Dim totaalAchterasNu As Integer


LastRow = Sheet2.Range("A65536").End(xlUp).Row + 1
 
If LastRow = 15 Then  'Kijken  of dit de eerste record is
   GegevensKopieren
Else

 TotaalVoorasEerst = Sheet2.Range("G15") + Sheet2.Range("L15")
 TotaalVoorasNu = Sheet1.Range("L11") + Sheet1.Range("L12")
 
 If Abs(TotaalVoorasEerst - TotaalVoorasNu) > 15 Then
    MsgBox "Opgelet!" & vbCrLf & "De waarde van de vooras wijkt meer dan 15kg af dan eerste de meting", vbInformation
 End If
 
 TotaalAchterasEerst = Sheet2.Range("Q15") + Sheet2.Range("V15")
 totaalAchterasNu = Sheet1.Range("L15") + Sheet1.Range("L16")
 
 If Abs(TotaalAchterasEerst - totaalAchterasNu) > 15 Then
    MsgBox "Opgelet!" & vbCrLf & "De waarde van de Achteras wijkt meer dan 15kg af dan eerste de meting", vbInformation
 End If

 GegevensKopieren
 
End If

 MsgBox "Alle data is opgeslagen"
 
End Sub

Sub GegevensKopieren()

  'Algemeen
   Sheet2.Range("A" & LastRow) = Sheet1.Range("E4")
   Sheet2.Range("B" & LastRow) = Sheet1.Range("P3")
   Sheet2.Range("W" & LastRow) = Sheet1.Range("O7")
   
  'LV
   Sheet2.Range("G" & LastRow) = Sheet1.Range("L11")
   Sheet2.Range("C" & LastRow) = Sheet1.Range("R22")
   Sheet2.Range("D" & LastRow) = Sheet1.Range("R25")
   Sheet2.Range("E" & LastRow) = Sheet1.Range("R28")
   
   'RV
   Sheet2.Range("L" & LastRow) = Sheet1.Range("L12")
   Sheet2.Range("H" & LastRow) = Sheet1.Range("R23")
   Sheet2.Range("I" & LastRow) = Sheet1.Range("R26")
   Sheet2.Range("J" & LastRow) = Sheet1.Range("R29")
   
   'LA
   Sheet2.Range("Q" & LastRow) = Sheet1.Range("L15")
   Sheet2.Range("M" & LastRow) = Sheet1.Range("R32")
   Sheet2.Range("N" & LastRow) = Sheet1.Range("R35")
   Sheet2.Range("O" & LastRow) = Sheet1.Range("R38")
   
   'RA
   Sheet2.Range("V" & LastRow) = Sheet1.Range("L16")
   Sheet2.Range("R" & LastRow) = Sheet1.Range("R33")
   Sheet2.Range("S" & LastRow) = Sheet1.Range("R36")
   Sheet2.Range("T" & LastRow) = Sheet1.Range("R39")
End Sub

Alles doet wat het moet doen .
Maar is dit allemaal niet op een andere manier te doen ?


Bedankt!

Romain

 

[Wigi]

Alles doet wat het moet doen .
Maar is dit allemaal niet op een andere manier te doen ?

Waarom zou je?

Waarover voel je je dan wat ongemakkelijk?

 

[Rommyke]

Hoi Wigi ,

Heb een gevoel dat de code wat korter kan .
Lijkt me zolangdradig voor die weinige acties dat ik maar moet uitvoeren.

Het kan maar een gedacht zijn .

Daarom jullie raad.

Bedankt !
Groet Romain