Hayırlı akşamlar arkadaşlar, bi konuda takıldım yardımcı olurmusunuz? sorun şu
texbox kutusu içine yazdığım değerleri tek tek arlarında boşluk bırakarak yazdığımda sayfa 1 den veriler geliyor,ama kopyala özel yapıştır diyip yapıştırınca veriler gelmiyor örnek ekte kodlar:
Sub parçala()
Application.ScreenUpdating = False
Range("A2:E" & Rows.Count).ClearContents
Dim mesaj$
mesaj = "Islem Tamamlandi."
If Me.TextBox1.Text <> Empty Then
'Dim i As Long
Dim son_satir&, bul As Range, ilk_adres$, silinecekler As Range
'a = Split(Replace(TextBox1.Text, " ", ""), ",")'
a = Split(Trim(TextBox1.Text), " ")
For s = LBound(a) To UBound(a)
Set bul = Sayfa1.Columns("D").Find(a(s), , , xlPart)
If Not bul Is Nothing Then
ilk_adres = bul.Address
Set silinecekler = bul
Do
Set silinecekler = Union(silinecekler, bul)
son_satir = Cells(Rows.Count, 1).End(3).Row + 1
Range("A" & son_satir & ":E" & son_satir).Value = Sayfa1.Range("A" & bul.Row & ":E" & bul.Row).Value
Set bul = Sayfa1.Columns("D").FindNext(bul)
Loop While Not bul Is Nothing And bul.Address <> ilk_adres
'silinecekler.EntireRow.Delete
Else
mesaj = "Aranan Koli no bulunamadi."
End If
Next s
Set bul = Nothing: son_satir = Empty: ilk_adres = Empty: Set silinecekler = Nothing
End If
Application.ScreenUpdating = True
MsgBox mesaj, vbInformation, "BILGI"
mesaj = Empty
'TextBox1.Text = Empty
End Sub
kolay gelsin..
http://s3.dosya.tc/server5/0fgkug/KOLI_NO_PARCALI_AKTAR.rar.html
texbox kutusu içine yazdığım değerleri tek tek arlarında boşluk bırakarak yazdığımda sayfa 1 den veriler geliyor,ama kopyala özel yapıştır diyip yapıştırınca veriler gelmiyor örnek ekte kodlar:
Sub parçala()
Application.ScreenUpdating = False
Range("A2:E" & Rows.Count).ClearContents
Dim mesaj$
mesaj = "Islem Tamamlandi."
If Me.TextBox1.Text <> Empty Then
'Dim i As Long
Dim son_satir&, bul As Range, ilk_adres$, silinecekler As Range
'a = Split(Replace(TextBox1.Text, " ", ""), ",")'
a = Split(Trim(TextBox1.Text), " ")
For s = LBound(a) To UBound(a)
Set bul = Sayfa1.Columns("D").Find(a(s), , , xlPart)
If Not bul Is Nothing Then
ilk_adres = bul.Address
Set silinecekler = bul
Do
Set silinecekler = Union(silinecekler, bul)
son_satir = Cells(Rows.Count, 1).End(3).Row + 1
Range("A" & son_satir & ":E" & son_satir).Value = Sayfa1.Range("A" & bul.Row & ":E" & bul.Row).Value
Set bul = Sayfa1.Columns("D").FindNext(bul)
Loop While Not bul Is Nothing And bul.Address <> ilk_adres
'silinecekler.EntireRow.Delete
Else
mesaj = "Aranan Koli no bulunamadi."
End If
Next s
Set bul = Nothing: son_satir = Empty: ilk_adres = Empty: Set silinecekler = Nothing
End If
Application.ScreenUpdating = True
MsgBox mesaj, vbInformation, "BILGI"
mesaj = Empty
'TextBox1.Text = Empty
End Sub
kolay gelsin..
http://s3.dosya.tc/server5/0fgkug/KOLI_NO_PARCALI_AKTAR.rar.html
