VBA: Søg og indsæt

Ja - det skulle nok være muligt - men hvordan er "forretnings-gangen" m.h.t.
- brugernes mulighed for ændringer?
- er det alle oplysningerne i rækken der overføres - eller udvalg?

Hej Supertekst

Undskyld min sene tilbagevenden - jeg blev nød til at gå fra pcen.

Det er oplysninger omkring medarbejderne. Dvs. om medarbejder har bil, telefon, om der skal være lønstigning mm. Principielt så kan alt ændres. Dog er det altid det samme "område" som vil skulle indsættes i den orginale liste igen. Det er vel 20-30 linjer, der bliver skildt ud på en medarbejder, og tanken var, at hvad end de havde ændret i det eller ej, så skal oplysningerne blot tilbage i den orginale liste igen.

Så det vil være alle rækker der skal overføres.

Jeg er glad for hjælpen.
På forhånd tak

hej jean01ad

ok - har du mulighed for at sende en model, der beskriver strukturen af ark1 - ark2 forventes at være tomt pr. definition.

Yes det kan jeg godt. Giv mig lige 30 minutter. så prøver jeg at lave en testmodel.

Hvilken E-mail skal jeg sende til?

E-mailen under din profil?

@-adresse under min profil

Sendt :-)

Tusind tak for hjælpen Supertekst - lig endelig et svar, det er en fornem løsning.

Følgende kode blev anvendt:

Const ændringsOmråde = "N16:N65"
Const detailFarve = 19

Dim arkPersonale As Worksheet

Dim kontonr As Long, initialer As String, beløb As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Address = "$M$12:$O$12" Then
        svar = MsgBox("Opdater ændringer?", vbYesNo)
        If svar = 6 Then
            Set arkPersonale = ActiveWorkbook.Sheets("Personale")

            findEvtÆndringer
        End If
    End If
End Sub
Private Sub findEvtÆndringer()
Dim celle, adr As String, pRæk As Long
   
    Application.ScreenUpdating = False
   
    For Each celle In Range(ændringsOmråde).Cells
        If celle.Interior.ColorIndex = detailFarve And _
            IsNumeric(celle.Value) = True And celle.Value <> "" Then
            adr = celle.Address
            kontonr = Range(adr).Offset(0, 2)
            initialer = Range("B3")
            beløb = Range(adr)
            pRæk = findRække(initialer, kontonr)
           
            If pRæk > 0 Then
                opdaterPersonaleÆndring pRæk, beløb
            Else
                MsgBox ("Række i Personale ej fundet vedr.: " & initialer & "/" & CStr(kontonr))
            End If
        End If
    Next celle
   
   
    pRæk = findFørsteRække(initialer)
    opdaterPersonaleIngenÆndringer initialer, pRæk
   
    arkPersonale.Activate
    arkPersonale.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub
Private Function findRække(initialer, kontonr)
Dim ræk As Long, række As String
   
    With arkPersonale
        For ræk = 2 To 65126
            række = ræk
            If .Range("A" & række) <> "" Then
                If .Range("B" & række) = initialer And .Range("D" & række) = kontonr Then
                    findRække = ræk
                    Exit Function
                End If
            Else
                Exit For
            End If
        Next ræk
    End With
   
    findRække = 0
End Function
Private Sub opdaterPersonaleÆndring(ræk, beløb)
Dim celle, adr As String, række As String
    række = ræk
    With arkPersonale
        For Each celle In .Range("A" & række & ":" & "H" & række).Cells
            adr = celle.Address
            .Range(adr).Offset(0, 13) = .Range(adr).Value
        Next

Rem test beløb
        If beløb <> 0 Then
            .Range("S" & række) = beløb
        End If
    End With
End Sub
Private Function findFørsteRække(initialer)
Dim ræk As Long, række As String
   
    With arkPersonale
        For ræk = 2 To 65126
            række = ræk
            If .Range("A" & række) <> "" Then
                If .Range("B" & række) = initialer Then
                    findFørsteRække = ræk
                    Exit Function
                End If
            Else
                Exit For
            End If
        Next ræk
    End With
   
    findFørsteRække = 0
End Function
Private Sub opdaterPersonaleIngenÆndringer(initialer, ræk1)
Dim celle, adr As String, række As String
   
    For ræk = ræk1 To 65126
        række = ræk
        With arkPersonale
            If .Range("B" & række) = initialer Then
Rem udfyld kun ikke allerede udfyldte rækker
                If .Range("N" & række) = "" Then
                    For Each celle In .Range("A" & række & ":" & "H" & række).Cells
                        adr = celle.Address
                        .Range(adr).Offset(0, 13) = .Range(adr).Value
                    Next
                End If
            Else
                Exit For
            End If
        End With
    Next ræk
End Sub