Indsættelse af celler fra en fane til et anden i excel

Hvis muligt er du velkommen til at din fil (evt. uddrag) til: pb@supertekst-it.dk

Jeg har sendt det til dig

Koden blev følgende:

Rem version 1
Rem =========
Dim ark1 As Worksheet
Dim arkIndtast As Worksheet
Dim ark2 As Worksheet

Dim invNr, tekst, By, Etage, foranTekstArk1
Sub Opdatering()                                    '<--- Knappen på arket Indtast aktiveret den SUB
    definerArk
   
    Application.ScreenUpdating = False
    ark1.Activate
    hentIndtastedeData
   
    findByEtagePåArk1
    Application.ScreenUpdating = True
   
    MsgBox ("Opdatering udført")
End Sub
Private Sub definerArk()
    With ActiveWorkbook
        Set ark1 = .Sheets("Ark1")
        Set arkIndtast = .Sheets("Indtast")
        Set ark2 = .Sheets("Ark2")
    End With
End Sub
Private Sub hentIndtastedeData()
    invNr = Range("B3").Value
    tekst = Range("C3").Value
    By = Range("D3").Value
    Etage = CStr(Range("E3").Value)
End Sub
Private Sub findByEtagePåArk1()
Const startRæk = 6
Dim slutRæk
    ark1.Activate
   
Rem traverser på Ark1
    slutRæk = ActiveCell.SpecialCells(xlLastCell).Row
    For r = startRæk To slutRæk
        If LCase(Trim(ark1.Cells(r, 2))) = LCase(By) Then
            findEtageArk1 r, slutRæk
            Exit Sub
        End If
    Next r
    MsgBox (By & " er ikke fundet på Ark1")
End Sub
Private Sub findEtageArk1(startRæk, slutRæk)
Dim tekst, fedSkrift
    For r = startRæk + 1 To slutRæk
        tekst = ark1.Cells(r, 3)
        fedSkrift = ark1.Cells(r, 3).Font.Bold
        If InStr(tekst, Etage) = 1 And fedSkrift = True Then
            findIndsættelsesRækkeArk1 r + 1, slutRæk
            Exit Sub
        End If
    Next r
    MsgBox (Etage & ". etage ikke fundet på Ark1")
End Sub
Private Sub findIndsættelsesRækkeArk1(startRække, slutRække)
Dim tekst, fedSkrift
Rem Skal finde Ny etage eller slutningen af Tabellen
    For r = startRække To slutRække
        tekst = ark1.Cells(r, 3)
        fedSkrift = ark1.Cells(r, 3).Font.Bold
        If fedSkrift = True Then
Rem Næste etage er fundet
            IndsætNyrækkeArk1 r
            Exit Sub
        Else
Rem Test om slutningen af tabel er nået
            If testKolonneBLtomArk1(r) = True Then
                IndsætNyrækkeArk1 r
                Exit Sub
            End If
        End If
    Next r
    MsgBox ("Ny række ikke fundet på Ark1")
End Sub
Private Function testKolonneBLtomArk1(række)
    testKolonneBLtomArk1 = True
   
    For Each cc In ark1.Range("B" & CStr(række) & ":L" & CStr(række)).Cells
        If cc.Value <> "" Then
            testKolonneBLtomArk1 = False
            Exit Function
        End If
    Next
End Function
Private Sub IndsætNyrækkeArk1(foranRække)
    foranTekstArk1 = ark1.Cells(foranRække, 3)

Rem Indsæt ny række på Ark2 inden af hensyn til formler ********
    findByEtagePåArk2

Rem Ark1
    ark1.Activate
   
    ark1.Rows(CStr(foranRække) & ":" & CStr(foranRække)).Select
    Selection.Insert Shift:=xlDown
   
    kopierFormlerFormat foranRække - 1, foranRække
Rem kopier formler fra række ovenfor
   
Rem Indsæt Inv.Nr & tekst i den nye række
    ark1.Cells(foranRække, 2) = invNr
    ark1.Cells(foranRække, 3) = tekst
End Sub
Private Sub kopierFormlerFormat(fraRæk, tilRæk)
Rem Overfør formler fra kolonnerne B - L
    udførKopiering "B", fraRæk, tilRæk
    udførKopiering "C", fraRæk, tilRæk
    udførKopiering "D", fraRæk, tilRæk
    udførKopiering "E", fraRæk, tilRæk
    udførKopiering "F", fraRæk, tilRæk
    udførKopiering "G", fraRæk, tilRæk
    udførKopiering "H", fraRæk, tilRæk
    udførKopiering "I", fraRæk, tilRæk
    udførKopiering "J", fraRæk, tilRæk
    udførKopiering "K", fraRæk, tilRæk
    udførKopiering "L", fraRæk, tilRæk
End Sub
Private Sub udførKopiering(kolonne, fraRæk, tilRæk)
Dim bagFarve
    ark1.Activate
   
    With ark1
Rem Kopier formel, hvis den findes i rækken ovenfor
        If .Range(kolonne & CStr(fraRæk)).HasFormula = True Then
            .Range(kolonne & CStr(fraRæk) & ":" & kolonne & CStr(tilRæk)).FillDown
        End If
       
Rem Kopier formatering fra rækken ovenfor
        .Cells(fraRæk, kolonne).Select
        bagFarve = Selection.Interior.ColorIndex
        Selection.Copy
        .Cells(tilRæk, kolonne).Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        Selection.Interior.ColorIndex = bagFarve
    End With
End Sub
Rem ************** ARK2 ********************
Private Sub findByEtagePåArk2()
Const startRæk = 4
Dim slutRæk
    ark2.Activate
   
Rem traverser på Ark2
    slutRæk = ActiveCell.SpecialCells(xlLastCell).Row
    For r = startRæk To slutRæk
        If InStr(LCase(Trim(ark2.Cells(r, 1))), LCase(By)) > 0 Then
            findEtageArk2 r, slutRæk
            Exit Sub
        End If
    Next r
    MsgBox (By & " er ikke fundet på Ark2")
End Sub
Private Sub findEtageArk2(startRæk, slutRæk)
Dim tekst, fedSkrift
    For r = startRæk + 1 To slutRæk
        tekst = ark2.Cells(r, 2)
        fedSkrift = ark2.Cells(r, 2).Font.Bold
        If InStr(tekst, Etage) = 1 And fedSkrift = True Then
            findIndsættelsesRækkeArk2 r + 1, slutRæk
            Exit Sub
        End If
    Next r
    MsgBox (Etage & ". etage ikke fundet på Ark2")
End Sub
Private Sub findIndsættelsesRækkeArk2(startRække, slutRække)
Dim tekst, fedSkrift
Rem Skal finde Ny etage eller slutningen af Tabellen
    For r = startRække To slutRække
        tekst = ark2.Cells(r, 2)
        If tekst = foranTekstArk1 Then
Rem Næste etage er fundet
            IndsætNyrækkeArk2 r
            Exit Sub
        Else
Rem Test om slutningen af tabel er nået
            If testKolonneBLtomArk2(r) = True Then
                IndsætNyrækkeArk2 r
            End If
        End If
    Next r
    MsgBox ("Ny række ikke fundet på Ark2")
End Sub
Private Function testKolonneBLtomArk2(række)
    testKolonneBLtomArk2 = True
   
    For Each cc In ark2.Range("A" & CStr(række) & ":C" & CStr(række)).Cells
        If cc.Value <> "" Then
            testKolonneBLtomArk2 = False
            Exit Function
        End If
    Next
End Function
Private Sub IndsætNyrækkeArk2(foranRække)
    ark2.Rows(CStr(foranRække) & ":" & CStr(foranRække)).Select
    Selection.Insert Shift:=xlDown
   
Rem Indsæt Inv.Nr & tekst i den nye række
    ark2.Cells(foranRække, 1) = invNr
    ark2.Cells(foranRække, 2) = tekst
End Sub