Avatar billede dkpret Nybegynder
18. november 2010 - 08:51 Der er 3 kommentarer og
1 løsning

Kopier kolonne eller række der opfylder betingelse

Hej

Excel 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.
Avatar billede finb Ekspert
18. november 2010 - 09:21 #1
følger bare tråden på magelig vis...
Avatar billede newbieatphp Nybegynder
20. november 2010 - 23:58 #2
Prøv leg lidt med det her:

Private Declare Function GetKeyState Lib "user32" _
(ByVal nVirtKey As Long) As Integer
Const VK_CONTROL As Integer = &H11 'Ctrl
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If GetKeyState(VK_CONTROL) < 0 Then
  Ctrl = True
Else
  Ctrl = False
End if

If Ctrl = True Then
  Rutine 2
Else
  Rutine 1
End If
End Sub


Men jeg ved dog ikke om CTRL er den bedste knap at sætte til det, da den normal vis vil tilføje den celle du trykker på, til den samlede markering i arket.
Avatar billede dkpret Nybegynder
22. november 2010 - 09:44 #3
Hej NewBieatphp

Du har ret i din betragtning omkring at CTRL er en uheldig taste at benytte grundet markerings issuet.
Jeg bruger så ALT tasten istedet = &H12 - så virker det.


Jeg har tilføjet koden som vist herunder og det virker.
Da jeg bruger beforedoubleclick på sheet'en undlader jeg SelectionChange(ByVal Target As Range)fra din kode - men bruger ellers den øvrige kode.

Tak for hjælpen - skriv et svar så du kan få pointene.  :-)

Dim værdi As Variant, række As Long, tilKol As Byte
Const startKolonne = 2
' første del af ny kode **************************
Private Declare Function GetKeyState Lib "user32" _
(ByVal nVirtKey As Long) As Integer
Const VK_CONTROL As Integer = &H12 'Alt
' ************************************************
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    værdi = Target.Value
    Cancel = True
' 2 del af ny kode *******************************
If GetKeyState(VK_CONTROL) < 0 Then
        ALT = True
    Else
        ALT = False
    End If

    If ALT = True Then
        Range("BB1") = "Rutine 2"
        ' udfør rutine 2
    Else
        Range("BB1") = "Rutine 1"
        ' udfør rutine 1
    End If
* ***********************************************
  Øvrig kode
Avatar billede newbieatphp Nybegynder
22. november 2010 - 14:33 #4
super :)
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester