Kopier kolonne eller række der opfylder betingelse
HejExcel 2003 - Windows XP - VBA
Jeg efterlyste på et tidspunkt en rutine til kopiering af kolonner der opfylder betingelse. Supertekst havde svaret med en
BeforeDoubleClick rutine der kopierer alle kolonner der opfylder betingelse at være have samme værdi i samme kolonne, som værdien der dobbeltklikkes på. (se nederst)
Det fungerer fint og jeg har med held konvereteret nedenstående rutine til også at kunne lave samme trick på rækker.
Nu til spørgsmålet.
Kan det lade sig gøre at kombinere BeforeDoubleClick rutinen med en funktion så man kan kombinere kopiering af kolonner eller rækker afhængig af om f.eks. CTRL holdes nede mens der dobbeltklikkes eller ej.
Dobbeltklik - så kopieres kolonner (rutine 1)
Dobbeltklik og CTRL samtidig holdes nede - så kopieres rækker (rutine 2)
Da jeg har styr på begge rutiner er det egenlig kun noget i stil med dette jeg efterlyser.
If BeforeDoubleClick and "CTRL pressed" then
Rutine 2
Else
Rutine 1
End If
*******************************************************
Koden fra Supertekst herunder (kopiering af kolonner)
Indlægges på Ark1 (Højreklik på fanen - vis programkode)
Aktiveres ved højreklik på ønskede værdi i ønskede række
--------------------------------------------------------
Dim værdi As Variant, række As Long, tilKol As Byte
Const startKolonne = 2
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
værdi = Target.Value
Cancel = True
tilKol = startKolonne
findværdi værdi, Target.Row
End Sub
Private Sub findværdi(værdi, række)
For kol = 1 To ActiveCell.SpecialCells(xlLastCell).Column
If Cells(række, kol) = værdi Then
kopierKolonne kol, tilKol
End If
Next kol
End Sub
Private Sub kopierKolonne(fraKol, tilKol)
Columns(fraKol).Select
Selection.Copy
ActiveWorkbook.Sheets("Ark3").Activate
ActiveSheet.Cells(1, tilKol).Select
ActiveSheet.Paste
tilKol = tilKol + 1
Application.CutCopyMode = False
ActiveWorkbook.Sheets("Ark1").Activate
End Sub
På forhånd tak.
