Brug af en IF funktion og kode?

Hvad med at anvende Dobbeltklik ?
eks.

Hvis du dobbeltklikker i A1, så overføres hele række 1 til andet ark i næste tomme række
Hvis du dobbeltklikker i A2, så overføres hele række 2 til andet ark i næste tomme række

Hej du,

Jeg ved ikke om det forrige svar virker. Det goer det ikke for mig i Excel 2003 i hver fald. Denne koden kopierer enhver raekke paa ark 1 som har en "X" i col A til en ny raekke paa ark 2...

Sub AB_CopyRows()
Dim R As Long, Rw As Long

With ThisWorkbook.Sheets(1)
    For R = 2 To .UsedRange.Rows.Count
        If .Cells(R, 1).Value = "x" Then
            .Rows(R).Copy
           
            With ThisWorkbook.Sheets(2)
                ' Find the first empty row
                For Rw = 2 To .UsedRange.Rows.Count + 1
                    If .Cells(Rw, 1).Value = "" Then
                        .Rows(Rw).PasteSpecial xlAll
                        Exit For
                    End If
                Next
            End With
        End If
    Next
End With

End Sub

Hej

Jeg har lagt koden ind i visual basic og compilet og "runnet" den

men når jeg sætter et x i A1 feltet, sker der ikke noget

Hvad gør jeg forkert?

Og der skal ikke grines, jeg er ikke excel nørd :)

Mvh
Timm

Hej

Jeg har lagt koden ind i visual basic og compilet og "runnet" den

men når jeg sætter et x i A1 feltet, sker der ikke noget

Hvad gør jeg forkert?

Og der skal ikke grines, jeg er ikke excel nørd :)

Mvh
Timm

Prøv denne lettere modificerede udgave af agatheb's kode. Bemærk, at den virker ift. den danske version af Excel 2003, hvor de to ark hedder Ark1 (indeholder den kolonne der skal kopieres fra hvis der er kryds i A1) og Ark2.

Sub AB_CopyRows()
Dim R As Long, Rw As Long

With ThisWorkbook.Sheets("Ark1")
    For R = 1 To .UsedRange.Columns.Count
        If .Cells(R, 1).Value = "x" Then
            .Columns(R).Copy
         
            With ThisWorkbook.Sheets("Ark2")
                ' Find the first empty column
                For Rw = 1 To .UsedRange.Columns.Count + 1
                    If .Cells(Rw, 1).Value = "" Then
                        .Columns(Rw).PasteSpecial xlAll
                        Exit For
                    End If
                Next
            End With
        End If
    Next
    Application.CutCopyMode = False
End With

End Sub

Hej Timm,

Bruger du VB eller VBA? Jeg har skrevet koden i VBA, maaske at det goer et forskel hvis du virker med VB (aner ikke meget om VB).

Hilsen,
Agathe

Højreklik på arkfanen hvor du indtaster x'er
Vælg Vis programkode
Indsæt koden der

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1:A500")) Is Nothing Then Exit Sub
If Application.WorksheetFunction.Proper(Target) = "X" Then
Target.EntireRow.Copy Sheets("Ark2").Cells(Sheets("Ark2").Cells(65000, 1).End(xlUp).Offset(1, 0).Row, 1)
End If
End Sub

rækken indsættes i Ark2, ret evt. i linie 4 til aktuel

Hej den virker rigtigt fint.

Skal jeg gøre noget særligt i koden hvis jeg vil have mere end "X" som en mulig udløser?

Jeg har prøvet med længere ord og ord med deling og der virker koden ikke. (jeg har ændret Xet i kodelininen til det jeg vil have den til at udløse på).

Tak og på forhånd tak
Timm

prøv:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1:A500")) Is Nothing Then Exit Sub
svar = Application.WorksheetFunction.Proper(Target)
If svar = "X" Or svar = "Y" Or svar = "Z" Then
Target.EntireRow.Copy Sheets("Ark2").Cells(Sheets("Ark2").Cells(65000, 1).End(xlUp).Offset(1, 0).Row, 1)
End If
End Sub

Det jeg egentligt ville var:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1:A500")) Is Nothing Then Exit Sub
If Application.WorksheetFunction.Proper(Target) = "data september" Then
Target.EntireRow.Copy Sheets("Ark2").Cells(Sheets("Ark2").Cells(65000, 1).End(xlUp).Offset(1, 0).Row, 1)
End If
End Sub

Eller:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1:A500")) Is Nothing Then Exit Sub
If Application.WorksheetFunction.Proper(Target) = "info august" Then
Target.EntireRow.Copy Sheets("Ark2").Cells(Sheets("Ark2").Cells(65000, 1).End(xlUp).Offset(1, 0).Row, 1)
End If
End Sub

Men når jeg gør dette kan jeg ikke få koden til at fungere i regnearket?

Tak for alle input indtil nu

Mvh
Timm

Du kan kun have 1' Change events i hver ark - prøv :

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1:A500")) Is Nothing Then Exit Sub
If Target = "info august" Or Target = "data september" Then
Target.EntireRow.Copy Sheets("Ark2").Cells(Sheets("Ark2").Cells(65000, 1).End(xlUp).Offset(1, 0).Row, 1)
End If
End Sub

Hej Excelent

Jeg har overvejet at ændre opbygning i skemaet, hvor feltet bliver en dropdownboks med flere valgmuligheder, og så var tanken, at hver valgmulighed skal flyttes over i et andet ark.

Altså info august til Ark 2, data september til Ark 3 og data oktober til Ark 4.

Kan man lave en kode der kan klare dette udfra en dropdown?

På forhånd tak
Timm