Flytte hele rader basert på verdi i enkeltceller i excel - makro

[Kaja100]

Hei!

 

Problemstillingen: jeg trenger å sette opp en automatisk kopiering av rader fra ett ark til et annet, gitt en betingelse, og vet ikke hvordan jeg skal sette opp makroen for dette.

 

Følgende ligger i ark2. Arket er navngitt "Nåsituasjon"

A1: Ansvarsnavn B1: Foreslått C1: Etternavn D1: Fornavn

 

Det er informasjon i rad 2 til rad 346.

 

Et eksempel

                   A               B                 C             D

Rad 1 Ansvarsnavn Foreslått   Etternavn Fornavn

Rad 2 Økonomi       Regnskap Petter     Hansen

 

Det jeg da ønsker er å sette opp en automatikk i at dersom det står "Regnskap" i kolonne B, skal raden med kolonnene B-D kopieres over i arket som jeg har kalt "Regnskap".

 

Jeg har ca 22 ark til (og 22 ulike titler under "Foreslått") så ideelt sett ønsker jeg å bruke samme makro, men det er jeg usikker på om går an? Er i så fall ikke imot å bruke samme kode flere ganger og kun endre betingelsen for kopiering.

 

Håper noen kan hjelpe meg!

 

Kaja

 

[ExcelGuru]

Morsom oppgave:)

Hvis du kjører makroen Flytt, flyttes alle linjene til respektive regneark. Hvis TIL-arket ikke finnes, blir det opprettet.

Du må ha med deg alle tre makroene:

 

Sub Flytt()

 Dim x As Long

 Dim Linje As Long

 Dim FaneNavn As String

 

 Dim FRA As Worksheet

 Dim TIL As Worksheet

 

 Set FRA = Sheets("Nåsituasjon")

 

 With FRA

  x = 2: While .Cells(x, 2) <> ""

   FaneNavn = .Cells(x, 2)

   

  

   'Sørg for at fanen finnes

   If FinnesFane(FaneNavn) = False Then

    Sheets.Add(After:=Sheets(Sheets.Count)).Name = FaneNavn

   End If

    

   'Nå vet vil at TIL-fanen finnes

    Set TIL = Sheets(FaneNavn)

    

   'Finn neste ledige linje i fanen som linjen skal til

   

   Linje = Ledig(TIL)

   

   With TIL

    y = 2: While y <= 4

     .Cells(Linje, y - 1) = FRA.Cells(x, y)

    y = y + 1: Wend

   End With

   

   x = x + 1: Wend

 End With

 

End Sub

 

Function Ledig(SH As Worksheet) As Long

 Dim x As Long

 With SH

  x = 2: While .Cells(x, 1) <> ""

  x = x + 1: Wend

  Ledig = x

  

 End With

End Function

 

Function FinnesFane(FaneNavn As String) As Boolean

 

 On Error GoTo feil

 

 With Sheets(FaneNavn)

  FinnesFane = True

  Exit Function

 End With

 

feil:

 FinnesFane = False

 

End Function