• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Hücre içeriği Kopyalama (İlk 4 Rakam)

S

sensizsoldum

Katılım
10 Ekim 2010
Mesajlar
1,469
Excel Vers. ve Dili
2010 Türkçe
Merhaba
B3:B Aralığına 7 haneli yüzlerce rakamsal değer giriyorum. Uzun bir zamanımı alıyor. Bir nebze olsa da bu işi kısa zamanda yapıp zaman kazanmam gerekiyor.
Örneğin B5 hücresinde 6627142 yazıyor. B6 hücresine 3 haneli yani 352 yazdığımızda bir üsteki hücrenin ilk 4 hanesini (6627) B6 hücrenin başına yazılması gerekiyor. Ben 352 yazdığımda hücrede 6627352 olmalı. Makro bu işlemi B3:B aralığına girilen rakam 3 haneli olursa yapmalı. Normal 3 hane dışında bir rakam girildiğinde herhangi bir işlem yapmamalı ve normal yazılan rakam yazılmalı.
Şirkette olduğumdan dosya ekleyemiyorum. Umarım yeterince açıkladım.
İyi çalışmalar dilerim.
Saygılarımla.
 
Merhaba

Bunu deneyiniz.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B3:B65536")) Is Nothing Then Exit Sub
If Len(Target.Text) <> 3 Then Exit Sub
sbt = Left(Cells(Target.Row - 1, Target.Column).Value, 4)
Target = sbt & Target.Value
End Sub
 
Merhaba Uzman Hocam,
İlginiz için teşekkür ederim. Bu kod bana hiç yabancı gelmedi. Bu kodla sanırım belirlenen hücrelere değer girildiğinde istenilen hücreye tarih yazılabiliyor. Ya da istenilen not yazılabiliyor. Ya da ben çok benzetiyorum.
Verdiğiniz kodu ben örnek çalışmada denedim. Kendi çalışmam da denedim. Fakat tam randımanlı çalışmıyor. Aşağıdaki verdiğim kodların arasına çalışabilecek şekilde uyarlaya bilirseniz sevinirim. Bu durumda çok zaman karım olacak gibi görünüyorum. Çok teşekkür ederim. İyi çalışmalar dilerim.
Saygılarımla.

Kod: 
'B sütuna girilen verinin bir üst yan hücrelerini bir alt satıra kopyalar
    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    
    If Intersect(Target, Range("B3:B" & Rows.Count)) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    If Target = "" Then
    r = Target.Row
    Cells(r, "A") = ""
    Cells(r, "B") = ""
    Cells(r, "C") = ""
    Cells(r, "D") = ""
    Cells(r, "E") = ""
    GoTo Son
    End If
    
    
    Satır = Cells(Rows.Count, 1).End(3).Row
    Cells(Target.Row, 1) = Cells(Satır, 1)
    Cells(Target.Row, 4) = Cells(Satır, 4)
    Cells(Satır, 3).Copy Cells(Target.Row, 3)
    Dim Satir As Long
    'B üstuna veri girildiğin de E sütunda 1 yazar
    If Target.Count = 1 Then
    If Target <> Empty Then
    Cells(Target.Row, "E") = 1
    Else
    Cells(Target.Row, "E") = Empty
    End If
    ElseIf Target.Count > 1 Then
    Satir = Cells(Rows.Count, 1).End(3).Row
    If Satir >= 3 Then
    With Range("E3:E" & Satir)
    .Formula = "=IF(B3="""","""",1)"
    .Value = .Value
    End With
    End If
    End If
Son:
Range("C2") = WorksheetFunction.Sum(Range("C3:C65536"))
Range("E2") = WorksheetFunction.Sum(Range("E3:E65536"))
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    End Sub
 
Merhaba

1 atımlık barutum vardı, bitti!
Gerekli düzenlemeyi başka arkadaşlar yapsın.

Bu arada;
...çok zaman karım olacak gibi...
Genişletmek için tıkla ...
kârım şeklinde yazılır!!!

Türkçe harflerdeki ^ işaretinin aklıevvel birileri tarafından kaldırıldığı bir dönemde gazetelerde "karımızı paylaşıyoruz" diye ilanlar vardı.
Bu tür ucubelere ortak olmayınız!..
 
Merhaba,
Şu şekilde anlatayım verdiğiniz kod sıradan örnek çalışmada sorunsuz istenilen gibi çalışmakta. Fakat ekleyeceğim, gerçek çalışmada randımanlı çalışmamaktadır. buda diğer kodlarla yeterince uyum sağlamadığından diye düşünüyorum.
 
Günaydın herkese, Hayırlı Sabahlar, Hayırlı cumalar.
Aşağıdaki kodları birleştiriyorum fakat randımanlı çalışmıyor. Sanırım Bazı kodlarda Çakışma oluyor. Birbirlerinin çalışmasına engel oluyor. Kodlarda minik değişiklikler yapılması gerekiyor, sanırım. Yardımcı olabilir misiniz.

Hayırlı Cumalar Dilerim.


Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B3:B65536")) Is Nothing Then Exit Sub
If Len(Target.Text) <> 3 Then Exit Sub
sbt = Left(Cells(Target.Row - 1, Target.Column).Value, 4)
Target = sbt & Target.Value
End Sub

Kod: 
'B sütuna girilen verinin bir üst yan hücrelerini bir alt satıra kopyalar
    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    
    If Intersect(Target, Range("B3:B" & Rows.Count)) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    If Target = "" Then
    r = Target.Row
    Cells(r, "A") = ""
    Cells(r, "B") = ""
    Cells(r, "C") = ""
    Cells(r, "D") = ""
    Cells(r, "E") = ""
    GoTo Son
    End If
    
    
    Satır = Cells(Rows.Count, 1).End(3).Row
    Cells(Target.Row, 1) = Cells(Satır, 1)
    Cells(Target.Row, 4) = Cells(Satır, 4)
    Cells(Satır, 3).Copy Cells(Target.Row, 3)
    Dim Satir As Long
    'B üstuna veri girildiğin de E sütunda 1 yazar
    If Target.Count = 1 Then
    If Target <> Empty Then
    Cells(Target.Row, "E") = 1
    Else
    Cells(Target.Row, "E") = Empty
    End If
    ElseIf Target.Count > 1 Then
    Satir = Cells(Rows.Count, 1).End(3).Row
    If Satir >= 3 Then
    With Range("E3:E" & Satir)
    .Formula = "=IF(B3="""","""",1)"
    .Value = .Value
    End With
    End If
    End If
Son:
Range("C2") = WorksheetFunction.Sum(Range("C3:C65536"))
Range("E2") = WorksheetFunction.Sum(Range("E3:E65536"))
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    End Sub
 
Merhaba
iki kodu birleştirdim.
Kod: 
Option Explicit

'B sütuna girilen verinin bir üst yan hücrelerini bir alt satıra kopyalar
    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    
    If Intersect(Target, Range("B3:B" & Rows.Count)) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
If Len(Target.Text) <> 3 Then Exit Sub
sbt = Left(Cells(Target.Row - 1, Target.Column).Value, 4)
Target = sbt & Target.Value
    If Target = "" Then
    r = Target.Row
    Cells(r, "A") = ""
    Cells(r, "B") = ""
    Cells(r, "C") = ""
    Cells(r, "D") = ""
    Cells(r, "E") = ""
    GoTo Son
    End If
    
    
    Satır = Cells(Rows.Count, 1).End(3).Row
    Cells(Target.Row, 1) = Cells(Satır, 1)
    Cells(Target.Row, 4) = Cells(Satır, 4)
    Cells(Satır, 3).Copy Cells(Target.Row, 3)
    Dim Satir As Long
    'B üstuna veri girildiğin de E sütunda 1 yazar
    If Target.Count = 1 Then
    If Target <> Empty Then
    Cells(Target.Row, "E") = 1
    Else
    Cells(Target.Row, "E") = Empty
    End If
    ElseIf Target.Count > 1 Then
    Satir = Cells(Rows.Count, 1).End(3).Row
    If Satir >= 3 Then
    With Range("E3:E" & Satir)
    .Formula = "=IF(B3="""","""",1)"
    .Value = .Value
    End With
    End If
    End If
Son:
Range("C2") = WorksheetFunction.Sum(Range("C3:C65536"))
Range("E2") = WorksheetFunction.Sum(Range("E3:E65536"))
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    End Sub
Not : Deneme yapılmamıştır. ( Sebebi konu anlaşılmadığı için )
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst