Seçili hücreyi ortalama

[fatihsun]

Merhaba,
Ekteki excell projesi;
Makina Listesinde makina kodunu seçtikten sonra Button 1 basarak TPM listesinde makina kodu sarıya boyanır ve çarpı işaretine göre süzdürülür.

Benim sorum;
Süzülen makina kodların işlem sonucunda TPM sheet'ininde direk gözükmemesidir. Ancak yön tuşları ile sağ veya sol ile hücrelerde ilerleyince ekrana gelmektedir.
VBA kodu ile bu işlemi nasıl yaparım?

 

[Korhan Ayhan]

Merhaba,

TPM isimli sayfanızın kod bölümüne aşağıdaki kodu uygulayıp deneyiniz.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Ust_Sutun = ActiveWindow.ActivePane.ScrollColumn
    Aktif_Sutun = Target.Column
    If Ust_Sutun >= Aktif_Sutun Then
        ActiveWindow.SmallScroll ToLeft:=Ust_Sutun - Aktif_Sutun + 5
    Else
        ActiveWindow.SmallScroll ToRight:=Aktif_Sutun - Ust_Sutun - 5
    End If
End Sub

 

[fatihsun]

Merhaba,

Verdiğiz kod için teşekkürler. Hücreyi istediğim gibi ortalıyor.

Fakat başka bir sorun ortaya çıktı. TPM sayfasında her hangi bir hücreye tıkladığımda sayfa sağa veya sola gitmektedir. Hücrelere müdehale edemiyorum.

Verdiğiniz kodu sadece butona basma işleminde nasıl çalıştırabiliriz?

 

[Korhan Ayhan]

Bu durumda sayfaya uyguladığınız kodu sildikten sonra butondaki kodunuzu aşağıdaki gibi değiştirip deneyin.

Sub Button1_Click()
    Dim i, SATIR, X, Mak_Kodu, Mak_Adı, Hat_Adı
    
Application.ScreenUpdating = False          'VB kodların çalışması bitmesini bekler
    
X = ActiveCell.Value    'Seçilen makina kodunu kaydeder

'--------------------Seçilen Makina kodunu kontrol et---------------------------
Sheets("Makine Listesi").Select
For i = 2 To Range("A400").End(xlUp).Row        'En son girilen hücreye kadar tarar.
    If Cells(i, "A") = X Then
        Mak_Kodu = Range("A" & i, "A" & i)      'Bulunan makina kodunu kaydet
        Mak_Adı = Range("B" & i, "B" & i)       'Bulunan makinanın adını kaydet
        Hat_Adı = Range("C" & i, "C" & i)       'Bulunan makinanın adını kaydet
        Range("A1").Select                      'Sayfa başına git
        GoTo 10:                                'Hat adı bulundu artık süzme işlemi başlasın.
    End If
Next

MsgBox "Seçilen Makina Kodu Bulunamadı"
Exit Sub
'----------------------------------------------------------------------------------

'--------------------TPM'de seçilen makina kodunu bulur---------------------------

10:
    Sheets("TPM").Select ' TPM Sayfasini secme
    SATIR = Range("XX4").End(xlToLeft).Column   'TPM'de makina kodlarının en son girilen hücrenin satır numarası
    
    Range(Cells(1, 23), Cells(1, SATIR)).ClearContents  'W1 hücresinden makin kod giriş son hücresine kadar sil.
    Range(Cells(4, 23), Cells(4, SATIR)).Interior.ColorIndex = xlNone 'Makina kod hücrelerinin rengini beyaz yap.
        
For i = 23 To SATIR                              'En son girilen sağ taraftaki hücreye kadar tarar.
    If Cells(4, i) = Mak_Kodu Then
        GoTo 20:                                'Hat adı bulundu artık süzme işlemi başlasın.
    End If
Next

    Range("B4") = "Seçilen Makina Kodu Bulunamadı"   'TPM sayfa başına sorunu yaz
    Range("B6") = "Seçilen Makina Kodu Bulunamadı"   'TPM sayfa başına sorunu yaz
    Range("B8") = "Seçilen Makina Kodu Bulunamadı"   'TPM sayfa başına sorunu yaz
    MsgBox "TPM'de Seçilen Makina Kodu Bulunamadı"
Exit Sub

'----------------------------------------------------------------------------------

'--------------------TPM'de bulunan makina Kodunu süzer---------------------------
20:
    Range("B4") = Hat_Adı                           'TPM sayfa başına Makina Listesinde bulunan Hat adını yaz
    Range("B6") = Mak_Adı                           'TPM sayfa başına Makina Listesinde bulunan Makina adını yaz
    Range("B8") = Mak_Kodu                          'TPM sayfa başına Makina Listesinde bulunan Makina kodunu yaz

    Cells(4, i).Interior.Color = vbYellow           'TMP'de bulunan makina kodunu sarıya boya
    Range(Cells(11, i), Cells(SATIR, i)).Select     'Otofiltreleme icin secim alaninin belirlenmesi
    Selection.AutoFilter
    Selection.AutoFilter Field:=1, Criteria1:="X"   'Hat adına göre otomatik filtreler
    AutoFilterMode = False                          'Otomatik filtreyi kaldır.
    Cells(4, i).Select                              'Makina kodunu seç
    
    Ust_Sutun = ActiveWindow.ActivePane.ScrollColumn
    Aktif_Sutun = ActiveCell.Column
    If Ust_Sutun >= Aktif_Sutun Then
        ActiveWindow.SmallScroll ToLeft:=Ust_Sutun - Aktif_Sutun + 5
    Else
        ActiveWindow.SmallScroll ToRight:=Aktif_Sutun - Ust_Sutun - 5
    End If

'----------------------------------------------------------------------------------
    
Application.ScreenUpdating = True           'VB kodların çalışması bitti
    
End Sub

 

[fatihsun]

Teşekkürler Korhan,

Tam istediğim gibi oldu.
Konuyu kapatabilirsiniz.