Makro ile birleştirme..

[policeman]

EĞER(V2="";"";BİRLEŞTİR(Q2&" "&R2&" "&"NO"&":"&S2&"/"&T2&" "&U2&"/"&V2)) formülü ile yapabildiğim birleştirme makro ile olabilir mi?
Saygılarımla...

 

[Ömer]

EĞER(V2="";"";BİRLEŞTİR(Q2&" "&R2&" "&"NO"&":"&S2&"/"&T2&" "&U2&"/"&V2)) formülü ile yapabildiğim birleştirme makro ile olabilir mi?
Saygılarımla...

Merhaba,

Bu şekilde deneyin.

Kodu çalıştırmadan önce sayfadaki açıklamaları silersiniz.

Sub Birlestir()
 
    Dim i As Long, son As Long, Wf As WorksheetFunction, j As Byte
    
    Set Wf = WorksheetFunction
    son = [Q:V].Find("*", , , , xlByRows, xlPrevious).Row
    
    Range("L2:L" & Rows.Count).ClearContents
    
    For i = 2 To son
        If Wf.CountA(Range("Q" & i & ":V" & i)) > 0 Then
            For j = 17 To 22
                Cells(i, "L") = Cells(i, "L") & " " & Cells(i, j)
            Next j
        End If
    Next i
        
End Sub

.

 

[policeman]

Sn. Ömer herhalde istediğimi yanlış aksettirdim.
1- QQQQ MAH. WWWW SK. 20 7 EYÜP İSTANBUL formatı QQQQ MAH. WWWW SK. NO:20/7 EYÜP/İSTANBUL şeklinde olursa,
2- Makroyu çalıştırdığımda L sütununda önceden kayıtlı olan adresler siliniyor,silinmesi gerekenler Q-R-S-T-U ve V sütunları olursa,
3- Makroyu çalıştırmak Alt+F8 ile değil;İl yazıldığında otomatik çalışırsa veya P sütununa çift tıklama ile olursa çok iyi olacak...
Yani sırasıyla Q,R,S,T,U ve V sütunlarına veriler girildiğinde vede V sütunundan çıktığımızda (veya P sütunanda ilgili satıra çift tıklamayla) girilen veriler istenilen formatta birleşerek L sütununa taşınırsa çok güzel olacak... Tabii ki mümkünse..
Saygılarımla..

 

[Ömer]

Hepsi mümkün. Tercihi bana bırakmadan siz yazarsanız sevinirim.

Yalnız tetikleme ile birleştirme kodunu çalıştıracaksanız, Q:V arasını silmek için ayrı bir kod yazmak ve bu kodu bağımsız çalıştırmak daha mantıklı olur. Ayrıca silme işlemi Q:V ve L de olacak sanırım.

.

 

[policeman]

Hocam ilgilendiğiniz için can-ı gönülden teşekkürler...
L sütunu kayıt yeri,kaydedilenler silinmeyecek;sadece Q:V arasındaki veriler kaydedildikten sonra silinecek..

 

[Ömer]

Hocam ilgilendiğiniz için can-ı gönülden teşekkürler...
L sütunu kayıt yeri,kaydedilenler silinmeyecek;sadece Q:V arasındaki veriler kaydedildikten sonra silinecek..

P sütununa çift tıklama ile işlem gören satırda kod çalışacaktır.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 
    Dim deg As String
 
    If Intersect(Target, Range("P2:P" & Rows.Count)) Is Nothing Then Exit Sub
 
    With Target
        If WorksheetFunction.CountA(Range("Q" & .Row & ":V" & .Row)) = 0 Then Exit Sub
        deg = Cells(.Row, "Q") & " " & Cells(.Row, "R") & "No:" & Cells(.Row, "S") & "/" & _
                Cells(.Row, "T") & " " & Cells(.Row, "U") & "/" & Cells(.Row, "V")
        Cells(.Row, "L") = deg
        Range("Q" & .Row & ":V" & .Row).ClearContents
    End With
 
End Sub

.

 

[policeman]

Hocam Allah razı olsun;tam istediğim gibi,çok sağolun...

 

[policeman]

Hocam makroyu kendi kitabıma adapte edemedim,yardımcı olurmusunuz?..

 

[policeman]

Sn. Ömer hocam oluşturduğunuz makroyu kendi programıma eklediğimde hata veriyor;anladığım kadarıyla benzer kodlamalar var..Nasıl ekleyeceğim hocam yardımcı olurmusunuz?..

 

[Ömer]

Sn. Ömer hocam oluşturduğunuz makroyu kendi programıma eklediğimde hata veriyor;anladığım kadarıyla benzer kodlamalar var..Nasıl ekleyeceğim hocam yardımcı olurmusunuz?..

İlaveyi kırmızı ile işaretledim.

Not: Detaylı deneme yapmadım. Hata alırsanız bildiriniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("a2:a" & [a65536].End(3).Row)) Is Nothing Then
If Target <> "" Then
Cancel = True
Application.ScreenUpdating = False
Set wd = CreateObject("Word.Application")
Set wddoc = wd.Documents.Add(DocumentType:=0)
wd.Visible = True
For x = 5 To 13
metin = metin & Chr(10) & Cells(1, x) & ": " & Cells(Target.Row, x)
Next
    With wd.Selection.PageSetup
        .PageWidth = wd.CentimetersToPoints(21)
        .PageHeight = wd.CentimetersToPoints(14.8)
    End With
wd.Selection = metin
yol_ds = ThisWorkbook.Path & "\" & Target & "-" & Cells(Target.Row, 8) & "-" & Cells(Target.Row, 2) & ".doc"
wddoc.SaveAs yol_ds
wddoc.Application.Quit
MsgBox "Aktarma tamamlanmıştır.", vbInformation, "Şakir ÖZKAN"
End If
End If
If Not Intersect(Target, Range("b1")) Is Nothing Then
Cancel = True
For y = 2 To [g65536].End(3).Row
Cells(y, 2) = WorksheetFunction.CountIf(Range("g2:g" & y), Cells(y, 7))
Next
End If
 
[COLOR=red]Dim deg As String[/COLOR]
[COLOR=red]If Not Intersect(Target, Range("P2:P" & Rows.Count)) Is Nothing Then[/COLOR]
[COLOR=red]    With Target
        If WorksheetFunction.CountA(Range("Q" & .Row & ":V" & .Row)) = 0 Then Exit Sub
        deg = Cells(.Row, "Q") & " " & Cells(.Row, "R") & "No:" & Cells(.Row, "S") & "/" & _
                Cells(.Row, "T") & " " & Cells(.Row, "U") & "/" & Cells(.Row, "V")
        Cells(.Row, "L") = deg
        Range("Q" & .Row & ":V" & .Row).ClearContents
    End With
    
End If[/COLOR]
 
End Sub

.

 

[policeman]

Sn. Ömer hocam bu sefer tamam oldu inşallah;tekrar tekrar mevlam razı olsun,çok teşekkürler..
Saygılarımla..

 

[Ömer]

Rica ederim, iyi çalışmalar.