Sütunu Aynı Biçimde Olan Verileri Boşluklarla Birleştirme

[jakida]

Merhaba, benim çözmek istediğim şöyle bir sorum var.

Yaklaşık 9000-10000 satırlık verilerle çalışıyorum. Bir sütunda yıldız isimleri var

Hip 122
Hip 814
Hip 4422
gibi. Yanlarındaki satırlarda da bu yıldıza ait bazı değerler var.

Başka bir excel verimde de yaklaşık 2000 tane (bu 2000 tanenin hepsi 10000 tanenin içinde yer alıyor) satır var.

Örneğin

Hip 122
Hip 4422

İkinci excel verisindeki yıldızların değerleri biraz daha detaylı. İkinci excel verisindeki değerleri birinci excel verisindeki değerlere serpiştirmek mümkün mü?

Ben bunu elle satır atlatarak yapıyorum. Ancak çok uzun zaman alıyor kolay yolu mutlaka vardır. Devamlı bunlarla uğraşıyorum, sadece bir seferlik yapacağım şey değil bu. Ekte excel dosyasının küçük bir örneğini paylaşıyorum.

Ekte A ve K Sütunları aynı. Çalışma sayfası 1'de tüm veriler var.
Çalışması Sayfası 2'de elle yaptığım şekli var.

Umarım anlatabilmişimdir. Yardım ederseniz, bana çok büyük zaman kazandırırsınız

 

[asi_kral]

Merhaba, benim çözmek istediğim şöyle bir sorum var.

Yaklaşık 9000-10000 satırlık verilerle çalışıyorum. Bir sütunda yıldız isimleri var

Hip 122
Hip 814
Hip 4422
gibi. Yanlarındaki satırlarda da bu yıldıza ait bazı değerler var.

Başka bir excel verimde de yaklaşık 2000 tane (bu 2000 tanenin hepsi 10000 tanenin içinde yer alıyor) satır var.

Örneğin

Hip 122
Hip 4422

İkinci excel verisindeki yıldızların değerleri biraz daha detaylı. İkinci excel verisindeki değerleri birinci excel verisindeki değerlere serpiştirmek mümkün mü?

Ben bunu elle satır atlatarak yapıyorum. Ancak çok uzun zaman alıyor kolay yolu mutlaka vardır. Devamlı bunlarla uğraşıyorum, sadece bir seferlik yapacağım şey değil bu. Ekte excel dosyasının küçük bir örneğini paylaşıyorum.

Ekte A ve K Sütunları aynı. Çalışma sayfası 1'de tüm veriler var.
Çalışması Sayfası 2'de elle yaptığım şekli var.

Umarım anlatabilmişimdir. Yardım ederseniz, bana çok büyük zaman kazandırırsınız

Merhaba
Boş bir module kodu kopyalayın ve deneyin.

Option Explicit
Sub kaydır_1967()
'Konu       :   Satırları Kaydır Eşitle
'Mail       :   m.batu.1967@gmail.com
'Coder By   :   asi_kral_1967
Dim asi, kral
Application.ScreenUpdating = False
For asi = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Cells(asi, "J") = Mid(Cells(asi, "A"), 1, WorksheetFunction.Search(" ", _
Cells(asi, "A")) - 1) & WorksheetFunction.Text(Mid(Cells(asi, "A"), _
WorksheetFunction.Search(" ", Cells(asi, "A")) + 1, Len(Cells(asi, "A")) - _
WorksheetFunction.Search(" ", Cells(asi, "A"))), "000000")
If Cells(asi, "K") <> Empty Then
Cells(asi, "O") = Mid(Cells(asi, "K"), 1, WorksheetFunction.Search(" ", _
Cells(asi, "K")) - 1) & WorksheetFunction.Text(Mid(Cells(asi, "K"), _
WorksheetFunction.Search(" ", Cells(asi, "K")) + 1, Len(Cells(asi, "K")) - _
WorksheetFunction.Search(" ", Cells(asi, "K"))), "000000")
End If
Next
Range("A2:J" & Rows.Count).Sort key1:=Range("J2"), order1:=xlAscending
Range("K2:O" & Rows.Count).Sort key1:=Range("O2"), order1:=xlAscending
Range("J:J").ClearContents: Range("O:O").ClearContents
For asi = 2 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(asi, "A") <> Cells(asi, "K") Then
Range("K" & asi & ":N" & asi).Insert shift:=xlDown
End If
Next
Application.ScreenUpdating = True
MsgBox "İşelm Tamamlandı", vbInformation, "asi_kral_1967"
End Sub

Dosyanız Ekte

 

[jakida]

Merhaba
Boş bir module kodu kopyalayın ve deneyin.

Option Explicit
Sub kaydır_1967()
'Konu       :   Satırları Kaydır Eşitle
'Mail       :   m.batu.1967@gmail.com
'Coder By   :   asi_kral_1967
Dim asi, kral
Application.ScreenUpdating = False
For asi = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Cells(asi, "J") = Mid(Cells(asi, "A"), 1, WorksheetFunction.Search(" ", _
Cells(asi, "A")) - 1) & WorksheetFunction.Text(Mid(Cells(asi, "A"), _
WorksheetFunction.Search(" ", Cells(asi, "A")) + 1, Len(Cells(asi, "A")) - _
WorksheetFunction.Search(" ", Cells(asi, "A"))), "000000")
If Cells(asi, "K") <> Empty Then
Cells(asi, "O") = Mid(Cells(asi, "K"), 1, WorksheetFunction.Search(" ", _
Cells(asi, "K")) - 1) & WorksheetFunction.Text(Mid(Cells(asi, "K"), _
WorksheetFunction.Search(" ", Cells(asi, "K")) + 1, Len(Cells(asi, "K")) - _
WorksheetFunction.Search(" ", Cells(asi, "K"))), "000000")
End If
Next
Range("A2:J" & Rows.Count).Sort key1:=Range("J2"), order1:=xlAscending
Range("K2:O" & Rows.Count).Sort key1:=Range("O2"), order1:=xlAscending
Range("J:J").ClearContents: Range("O:O").ClearContents
For asi = 2 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(asi, "A") <> Cells(asi, "K") Then
Range("K" & asi & ":N" & asi).Insert shift:=xlDown
End If
Next
Application.ScreenUpdating = True
MsgBox "İşelm Tamamlandı", vbInformation, "asi_kral_1967"
End Sub

Dosyanız Ekte

@asi_kral_1967

Çok ama çok teşekkür ederim. Benim için olağanüstü bir şey bu.

Harikasın!

 

[asi_kral]

@asi_kral_1967

Çok ama çok teşekkür ederim. Benim için olağanüstü bir şey bu.

Harikasın!

Kolay Gelsin.

 

[jakida]

Kolay Gelsin.

Tekrar Merhaba,

Biraz kodu anlamaya çalışıyorum da.

Benim gönderdiğim örnek deneme içindi normalde bende J ve O sütunları da dolu.
Buralarda yapılanlan işlemleri daha uzak bi yere atamak mümkün mü ?

Yukarıdaki Örnekteki A sütununda yazan yerlere BR, K sütunu yazan yerlere de BS yapmam gerek ancak O ve J sütunları da dolu. Bunları nasıl değiştirebilirim.

25mb'tan büyük de excel dosyası gönderemedim o yüzden tekrar. Eğer o kadar kolay değilse kendi çalıştığımı küçülteyim

 

[asi_kral]

Tekrar Merhaba,

Biraz kodu anlamaya çalışıyorum da.

Benim gönderdiğim örnek deneme içindi normalde bende J ve O sütunları da dolu.
Buralarda yapılanlan işlemleri daha uzak bi yere atamak mümkün mü ?

Yukarıdaki Örnekteki A sütununda yazan yerlere BR, K sütunu yazan yerlere de BS yapmam gerek ancak O ve J sütunları da dolu. Bunları nasıl değiştirebilirim.

25mb'tan büyük de excel dosyası gönderemedim o yüzden tekrar. Eğer o kadar kolay değilse kendi çalıştığımı küçülteyim

Dosyanız'ın üst satırını kopyalayın ve boş bir satıra kopyalayın.
Altındaki verilerden de 25 satır kopyalayıp gönder bir daha bakayım. Dosyayı görmeden bir işlem yapamam çünkü önce sıralama yaptırıyorum ki eşit sıra olsun diye.

 

[jakida]

Dosyanız'ın üst satırını kopyalayın ve boş bir satıra kopyalayın.
Altındaki verilerden de 25 satır kopyalayıp gönder bir daha bakayım. Dosyayı görmeden bir işlem yapamam çünkü önce sıralama yaptırıyorum ki eşit sıra olsun diye.

Ekte gönderiyorum. İnanın bana mucizevi bir iyilik yapmış olacaksınız.

Dosyadaki BR Sütunu için BS sütununu serpiştirmek istiyorum.

52. satırdan itibaren değişim başlıyo görünüyor.

BS sütununun sağında kalan tüm verilerle birlikte (CQ'ya kadar)