Új hozzászólás Aktív témák

• #44293 Pakliman tag Telda #44291

  Új Válasz 2020-06-17 13:20:14 #44293

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Pakliman

  tag

  válasz Telda #44291 üzenetére

  Szia!

  Egy kis makrózással megoldható...

  Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address = Range("A1").Address Then
'Duplaklikk az A1 cellán

Cancel = True 'Megakadályozzuk, hogy szerkesztő módba lépjen a cellában.

Dim sha As Worksheet: Set sha = Worksheets("Munka1") 'ActiveSheet
Dim shk As Worksheet: Set shk = Worksheets("Munka2")
Dim usa As Long: usa = sha.Cells(sha.Rows.Count, "A").End(xlUp).Row 'A Munka1 utolsó sora
Dim usk As Long: usk = shk.Cells(shk.Rows.Count, "A").End(xlUp).Row 'A Munka2 utolsó sora
Dim sora As Long
Dim sork As Long

'Nem kell folyton újraszámolni, sem villogtatni a képet...
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Kiürítjük a B oszlopot...
sha.Range("B2:B" & usa).ClearContents
For sora = 2 To usa
For sork = 2 To usk
If sha.Cells(sora, 1) Like shk.Cells(sork, 1) & "*" Then
'Ha a Munka1 aktuális cellája "hasonlít" a Munka2 aktuális cellájára, akkor...
sha.Cells(sora, 2) = 1 '...a Munka2 2. oszlopába berakunk egy 1-est
Exit For 'Mivel van találat, a több elemet már nem vizsgáljuk, továbblépünk...
End If
Next sork
Next sora

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

Új hozzászólás Aktív témák