Kopier indhold af celler hvis cellen i række S indeholder en værdi

Hejsa,

Herunder er vedhæftet et forslag til løsning.

---------------------------------------------

Sub Celle_kopiering()

    Dim RK As Long
   
    Cells(22, 2).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
   
    RK = 2
   
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 2).Select
    ActiveSheet.Paste
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until Cells(RK, 18) = "Conclusion"
    Application.CutCopyMode = False
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 7).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 7).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until Cells(RK, 18) = "Conclusion"
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 2).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 2).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until Cells(RK, 18) = "Conclusion"
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 3).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 3).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until Cells(RK, 18) = "Conclusion"
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 4).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 4).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until Cells(RK, 18) = "Conclusion"
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 5).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 5).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until Cells(RK, 18) = "Conclusion"
    Cells(2, 2).Select
End Sub

---------------------------------------------

Med venlig hilsen

Henrik

Hej Henrik,

SUPER, det ser rigtig godt ud, jeg har dog 2 problemer.

1. Loop Until "Conclusion": Her skal der nok en "*" efter, da cellen kan indeholde mere end denne tekst.

2. Har fundet ud af, at jeg også har en tekst i rækken R som skal kopieres til række B med fed skrift og venstre stilles.
Det gælder KUN celler som indeholder en "(".

Er det noget du kan tilføje?

/Søren

Hej Søren,

Jeg kigger lige på det og vender frygteligt tilbage senest tirsdag i næste uge. (Håber at det bliver før...)

/Henrik

Hej igen,

Bedre sent end aldrig....

Herunder et forslag til en løsning.

Håber den kan bruges... Jeg var i tvivl om hvorvidt den parantes du nævner i kolonne R skulle med, eller om det kun var den tekst/værdi der stod i cellen, men indtil videre er parantesen med. Det vil dog ikke være noget større problem at fjerne den.

For at få det til at gå op benytter jeg rent faktisk kolonne U til nogle formler som slettes igen, men det betyder dog, at du ikke kan bruge denne kolonne.

Også dette vil være forholdsvis enkelt at ændre, hvis du mener at der er risiko/sandsynlighed for at du kommer til at få brug for den kolonne.

Nok "snak"... Herunder et løsningsforslag...

-----------------------------------------------

Sub Celle_kopiering()

    Dim RK As Long
    Dim Slut As String
    Dim RKO As Integer
    Dim KKO As Integer
   
    Columns("R:R").Select
    Selection.Find(What:="Conclusion", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Select
   
    RKO = ActiveCell.Row
    KKO = ActiveCell.Column
   
    Cells(22, 2).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
   
    RK = 2
   
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 2).Select
    ActiveSheet.Paste
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
    Application.CutCopyMode = False
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 7).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 7).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 2).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 2).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 3).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 3).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 4).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 4).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 5).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 5).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
   
    RK = 2
    Do
    Cells(RK, 21).Select
    ActiveCell.FormulaR1C1 = _
        "=LEFT(RC[-3],1)"
    RK = RK + 1
    Loop Until RK = RKO + 1
    Cells(2, 2).Select
   
    Columns(22).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
   
    RK = 2
    Do
    If Cells(RK, 21) = "(" Then
    Cells(RK, 18).Select
    Selection.Copy
    Cells(RK, 2).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
    Columns(21).Delete
    Cells(2, 2).Select
   
End Sub

----------------------------------------------------

Med venlig hilsen

Henrik

Hej Henrik,

Nu virker det fint med Conclusion.

Det sidste loop (Række R) skal dog ændres da cellen også indeholder anden tekst, men kun der hvor teskten indeholder en ( at hele cellen skal kopires til Række B

Den formel kolonne du har lavet i Række U har jeg flyttet til Y.

Med venlig hilsen
Søren

Hej igen,

Er ikke helt sikker på at jeg forstod hvad du mente men nu har jeg ændret det, så den bruger Y istedet for U til formlen og derudover har jeg bedt den om at slette indholdet i celle B hvis der ikke er en parantes i celle R.
Håber at det var det du mente og ellers må du lige forklare det igen, så selv jeg kan fatte hvad du mener (hvilket kan være en opgave i sig selv he he...)

----------------------------------

Sub Celle_kopiering()

    Dim RK As Long
    Dim Slut As String
    Dim RKO As Integer
    Dim KKO As Integer
   
    Columns("R:R").Select
    Selection.Find(What:="Conclusion", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Select
   
    RKO = ActiveCell.Row
    KKO = ActiveCell.Column
   
    Cells(22, 2).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
   
    RK = 2
   
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 2).Select
    ActiveSheet.Paste
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
    Application.CutCopyMode = False
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 7).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 7).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 2).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 2).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 3).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 3).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 4).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 4).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
   
    RK = 2
    Do
    If Cells(RK, 19) <> "" Then
    Cells(RK, 5).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(RK, 5).Select
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
   
    RK = 2
    Do
    Cells(RK, 25).Select
    ActiveCell.FormulaR1C1 = _
        "=LEFT(RC[-7],1)"
    RK = RK + 1
    Loop Until RK = RKO + 1
    Cells(2, 2).Select
   
    Columns(25).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
   
    RK = 2
    Do
    If Cells(RK, 25) = "(" Then
    Cells(RK, 18).Select
    Selection.Copy
    Cells(RK, 2).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    RK = RK + 1
    Else
    Cells(RK, 2) = ""
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1
    Columns(25).Delete
    Cells(2, 2).Select
   
End Sub

---------------------------------

Med venlig hilsen

Henrik

Hej Henrik,

Mange tak for løsninger, jeg har rette lidt i den sidste løsning så nu virker det smo det skal.

    Do
    If Right(Cells(RK, 18).Value, 1) = ")" Then
    Cells(RK, 18).Select
    Selection.Copy
    Cells(RK, 2).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    RK = RK + 1
    Else
    RK = RK + 1
    End If
    Loop Until RK = RKO + 1

Vil du smide et svar, så tildeler jeg point
   
Med venlig hilsen
Søren

Et stk svar fra mig til dig :-)