Makroda butonla süzerek sayfalar arası veri aktarımı (hücrelerde metin ve sayı karışık)

A

anneke

Katılım
7 Temmuz 2016
Mesajlar
6
Excel Vers. ve Dili
2013 ingilizce
Altın Üyelik Bitiş Tarihi
16-08-2022
Merhaba,

Excelde Sheet1'de oluşturduğum tabloya Sheet2'deki belli verileri butonla Sheet1'de ilgili alanlara getirmek istiyorum. Sheet2'deki veriler düzenli değil, PDF'i kopyala yapıştır yoluyla Sheet2'ye aktarıyorum. (İşlemi daima bu şekilde yapmalıyım) Metinler ve sayılar hücreler içerisinde karışık şekilde geliyor. Ayrıca verileri sıralı şekilde de aktarmak istemiyorum. Tablodaki sıralama ile Sheet2'de sıralama eşleşmiyor o nedenle istediğim alanlar, butona basınca aktarılsın istiyorum.

Örnek olarak;
Sheet1'de Satış verileri 2019 alanına (B3), Sheet2'deki 2019 satış verisini (A121) getirsin istiyorum. A121'deki bu veri; "satışlar 10.800 20.200" olarak tek hücrede metin-sayı karışık olarak kayıtlı. İlk satış tutarı 2019'a diğer satış tutarı 2020'ye ait. Tabloya hücreden gerekli alanı seçerek gelmesi gerekiyor.

Yardımlarınızı rica eder, emekleriniz için teşekkür ederim.
Kolay gelsin.
 
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Kod: 
Sub test()
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    s1.Range("B3:C" & Rows.Count).ClearContents
    son1 = s1.Cells(Rows.Count, 1).End(3).Row
    son2 = s2.Cells(Rows.Count, 1).End(3).Row
    Dim w(1 To 1, 1 To 2)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To son2
            bl = Split(s2.Cells(i, 1), " ")
            krt = ""
            If UBound(bl) > 1 Then
                For ii = 0 To UBound(bl) - 2
                    krt = Trim(krt & " " & bl(ii))
                Next ii
                If Not .exists(krt) Then
                    w(1, 1) = Val(Replace(bl(UBound(bl) - 1), ".", ""))
                    w(1, 2) = Val(Replace(bl(UBound(bl)), ".", ""))
                    .Item(krt) = w
                End If
            End If
        Next i
        For i = 3 To son1
            krt = s1.Cells(i, 1)
            If .exists(krt) Then
                s1.Cells(i, 2).Resize(, 2).Value = .Item(krt)
            End If
        Next i
    End With
End Sub
 
A

anneke

Katılım
7 Temmuz 2016
Mesajlar
6
Excel Vers. ve Dili
2013 ingilizce
Altın Üyelik Bitiş Tarihi
16-08-2022
Çok teşekkürler ancak makroyu çalıştırdığımda type mismatch hatası alıyorum. Veriyi metin yerine sayı olarak düzenlediğimde de hata devam ediyor. Ne önerirsiniz?
 
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Örnek dosya ekleyin, hata gerçekleştiği zaman debug'ı tuşlayarak hatanın oluştuğu satırın fotoğrafını atabilirsiniz.
 
A

anneke

Katılım
7 Temmuz 2016
Mesajlar
6
Excel Vers. ve Dili
2013 ingilizce
Altın Üyelik Bitiş Tarihi
16-08-2022
Merhaba, üyelik nedeni ile örnek dosya yükleyememistim. Yarın yükleyecegim. Hatanın gerceklestigi satır If UBound(bl) > 1 Then olarak görünüyor.
 
A

anneke

Katılım
7 Temmuz 2016
Mesajlar
6
Excel Vers. ve Dili
2013 ingilizce
Altın Üyelik Bitiş Tarihi
16-08-2022
Merhabalar, bu konuda bir geri dönüş olmadı. Desteklerinizi rica ederim.
 
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Kodların sonucun doğru olup olmadığın denetlemedim, zira Sheet2 de bir çok Türkçe olan ve Olmayan satırlar var.
Kodların başına aşağıdaki satırı ekledim
C++: 
On Error Goto Hata ' Eklediğim satır'
With CreateObject("Scripting.Dictionary")
En Sub hemen önüne de aşağıdaki kodu ekledim ki hataya sebep olan satışı görelim.
Kod: 
Hata:
MsgBox "i=" & i & vbCrLf & "ii=" & ii
End Sub
Hata veren satırınızın 466 olduğunu, 466 satırında da
=-@Ünvanı formülünü, formül sonucununda haliyle #AD? olarak görüldüğünü farkettim.

Bu durumu düzeltmek için, yukarıda ilave ettiğim satırları silip yada pasif hale getirip orjinal kodlarda ilk For döngüsünün altına aşağıdaki satırı ekledim.
C++: 
        For i = 1 To son2
            If IsError(s2.Cells(i, 1)) Then s2.Cells(i, 1) = 0
Sonuç olarak Sheet1 sayfasında sadece bir tane satıra veri geldiğini ancak hata olmadığını gördüm.
Sanırım Türkçe karakter sorununu çözünce kodlar işlevini görecektir.
 
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Ayrıca dosyayı inceliyorum.

Sheet 1 ... Satışlar diye yazılmış
Sheet 2 ... Satıslar diye

Net Kar .. Sheet1 de 1 datırda, Sheet2 de 3 satırda var
Dönen Varlıklar Sheet1 de 1 datırda, Sheet2 de 2 satırda var

Bu örnekler çoğalıyor.
Bunların nasıl çözüleceğini, bir sonraki PDF den averi çektiğinizde formatların değişip değişmeyeceğini sizi biliyorsunuz.
Hangi satırdaki Net Kar alıncak mesela? Siz söylemelisiniz. Siz tarif etmelisiniz ki excel doğrusunu yapsın.
 
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Sheet2 den alınan veriler E:H sütununda gösterilmiştir. F sütununu ile A sütunu eşleşmesi halinde işlem gerçekleşecektir. A sütunundaki verilerde ş yi s, ç yi c olarak çevirip arama işlemi yapılmıştır. A sütunundaki başlıkları F sütunundaki indexlere göre ayarlayıp biraz daha fazla sonuca ulaşabilirsiniz.
Benden bu kadar.
Kod: 
Sub test()
    Set s1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    s1.Range("B3:C" & Rows.Count).ClearContents
    s1.Range("E:H").ClearContents
    son1 = s1.Cells(Rows.Count, 1).End(3).Row
    son2 = S2.Cells(Rows.Count, 1).End(3).Row
    Dim w(1 To 1, 1 To 2)
    Set regexp = CreateObject("VBscript.Regexp")
    regexp.Pattern = "(.+)\s([\d\.\,]{3,})\s([\d\.\,]{3,})"
    regexp.Global = True
    With CreateObject("Scripting.Dictionary")
        For I = 1 To son2
            al = (S2.Cells(I, 1).Value)
            If IsError(al) Then GoTo skip
            al = WorksheetFunction.Proper(S2.Cells(I, 1).Value)

            If regexp.test(al) Then
                sat = sat + 1
                Sheets("Sheet1").Cells(sat, "E").Value = al
                If Left(al, 1) = "." Then al = Mid(al, 2)
                If InStr(2, al, ".") < 5 Then al = Mid(al, InStr(2, al, ".") + 1)
                al = StrReverse(al)
                bl = Split(al, " ")
                w(1, 1) = Val(Replace(Replace(StrReverse(bl(1)), ".", ""), ",", "."))
                w(1, 2) = Val(Replace(Replace(StrReverse(bl(0)), ".", ""), ",", "."))
                bl(0) = ""
                bl(1) = ""
                al = Trim(StrReverse(Join(bl, " ")))
                If Right(al, 3) = "(-)" Then al = Trim(Left(al, Len(al) - 3))
                Sheets("Sheet1").Cells(sat, "F").Value = al
                Sheets("Sheet1").Cells(sat, "G").Resize(, 2).Value = w
                .Item(al) = w
            End If
skip:
        Next I
        For I = 3 To son1
            krt = WorksheetFunction.Proper(Replace(Replace(s1.Cells(I, 1), "ş", "s"), "ç", "c"))
            If .exists(krt) Then
                s1.Cells(I, 2).Resize(, 2).Value = .Item(krt)
            End If
        Next I
    End With
End Sub
 
A

anneke

Katılım
7 Temmuz 2016
Mesajlar
6
Excel Vers. ve Dili
2013 ingilizce
Altın Üyelik Bitiş Tarihi
16-08-2022
veyselemre' Alıntı:
Sheet2 den alınan veriler E:H sütununda gösterilmiştir. F sütununu ile A sütunu eşleşmesi halinde işlem gerçekleşecektir. A sütunundaki verilerde ş yi s, ç yi c olarak çevirip arama işlemi yapılmıştır. A sütunundaki başlıkları F sütunundaki indexlere göre ayarlayıp biraz daha fazla sonuca ulaşabilirsiniz.
Benden bu kadar.
Kod: 
Sub test()
    Set s1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    s1.Range("B3:C" & Rows.Count).ClearContents
    s1.Range("E:H").ClearContents
    son1 = s1.Cells(Rows.Count, 1).End(3).Row
    son2 = S2.Cells(Rows.Count, 1).End(3).Row
    Dim w(1 To 1, 1 To 2)
    Set regexp = CreateObject("VBscript.Regexp")
    regexp.Pattern = "(.+)\s([\d\.\,]{3,})\s([\d\.\,]{3,})"
    regexp.Global = True
    With CreateObject("Scripting.Dictionary")
        For I = 1 To son2
            al = (S2.Cells(I, 1).Value)
            If IsError(al) Then GoTo skip
            al = WorksheetFunction.Proper(S2.Cells(I, 1).Value)

            If regexp.test(al) Then
                sat = sat + 1
                Sheets("Sheet1").Cells(sat, "E").Value = al
                If Left(al, 1) = "." Then al = Mid(al, 2)
                If InStr(2, al, ".") < 5 Then al = Mid(al, InStr(2, al, ".") + 1)
                al = StrReverse(al)
                bl = Split(al, " ")
                w(1, 1) = Val(Replace(Replace(StrReverse(bl(1)), ".", ""), ",", "."))
                w(1, 2) = Val(Replace(Replace(StrReverse(bl(0)), ".", ""), ",", "."))
                bl(0) = ""
                bl(1) = ""
                al = Trim(StrReverse(Join(bl, " ")))
                If Right(al, 3) = "(-)" Then al = Trim(Left(al, Len(al) - 3))
                Sheets("Sheet1").Cells(sat, "F").Value = al
                Sheets("Sheet1").Cells(sat, "G").Resize(, 2).Value = w
                .Item(al) = w
            End If
skip:
        Next I
        For I = 3 To son1
            krt = WorksheetFunction.Proper(Replace(Replace(s1.Cells(I, 1), "ş", "s"), "ç", "c"))
            If .exists(krt) Then
                s1.Cells(I, 2).Resize(, 2).Value = .Item(krt)
            End If
        Next I
    End With
End Sub
Genişletmek için tıkla ...

Çok teşekkür ederim emekleriniz için. İstediğim sonuca ulaşabildim. Kolaylıklar, başarılar dilerim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst