AccessTr.neT

Önceki mesajdaki ilgili modül kodu alttaki gibi değiştirin eğer kullanacaksanzı abey.
Bence dediğiniz  0 ve formül olayı için konu açın whatsap sayfasına gerek olmadan anasayfa numaralarından yollansın.

Sub Whatsap_ekle_sil_guncelle()



Dim sonAna As Long, kac As Long

Dim syfAna As Worksheet, hatalimi As Boolean



Set syfAna = ThisWorkbook.Worksheets("Ana_Sayfa")



Application.ScreenUpdating = False

sonAna = syfAna.Range("A:A").Find("*", , , , , xlPrevious).Row

hatalimi = False



With ThisWorkbook.Worksheets("WHATSAPP")

  .Unprotect "171717"

    .Range("A2:A" & Rows.Count).ClearContents

    

    If sonAna < 2 Then

        hatalimi = True: GoTo son

    End If



    kac = WorksheetFunction.CountA(syfAna.Range("A2:A" & Rows.Count))

    If kac = 1 Then

        .Range("A2").Value = syfAna.Cells(sonAna, "AD").Value

        GoTo son

    End If

    .Range("A2:A" & sonAna).Value = syfAna.Range("AD2:AD" & sonAna).Value

son:

Application.ScreenUpdating = True

.Protect "171717"

End With

On Error Resume Next

If hatalimi = True Then

    MsgBox "Kaydedilecek yada güncellenecek yada silinecek veri yok.", vbCritical, "Hata"

Else

    MsgBox "islem tamam.", vbInformation, "Bilgi"

End If

Set syfAna = Nothing

End Sub

(16/05/2021, 19:26)feraz yazdı: [ -> ]Bence whatapp sayfadan yollamak sakıncalı.
Yolladığım kodla gönderecekseniz kodu kısaltınca eklerim,uzamış biraz

@feraz hocam ​Bu kodu kullanacağım başka kod yok
Sakıncalı derken neyi kastettiniz. Biraz açarmısınız. Kodu denedim gayet güzel çalışıyor, fakat 8 numaralı satır boş şekilde duruyor. Bu satır diğer boş satırlar gibi ortadan kalkmamış neden kaynaklanabilir acaba. Resmi gönderemiyorum.

(16/05/2021, 19:45)Oğuz Türkyılmaz yazdı: [ -> ]

(16/05/2021, 19:26)feraz yazdı: [ -> ]Bence whatapp sayfadan yollamak sakıncalı.
Yolladığım kodla gönderecekseniz kodu kısaltınca eklerim,uzamış biraz

@feraz hocam Bu kodu kullanacağım başka kod yok
Sakıncalı derken neyi kastettiniz. Biraz açarmısınız. Kodu denedim gayet güzel çalışıyor, fakat 8 numaralı satır boş şekilde duruyor. Bu satır diğer boş satırlar gibi ortadan kalkmamış neden kaynaklanabilir acaba. Resmi gönderemiyorum.

Dictionay ile yaptığım kod sakıncalıydı çünkü kelefon numaralı birden fazla aynı varsa tekini alır.
Son eklediğim kod ise ana sayfadaki verilerle birebir aynısı olur bu daha iyi.

Yaptığım şuydu Anasayfakaki Ad ile sütundaki tüm verileri whatsap sayfasının A sütununa birebir aynısı eklettim.

Dediğim gibi yeni konu açın bakarız boş olay için.

(16/05/2021, 19:09)feraz yazdı: [ -> ]

(16/05/2021, 18:35)Oğuz Türkyılmaz yazdı: [ -> ]Formül sorun yaratıyor feraz hocam zaten hücrede 0 olmuş yada boş olmuş farketmiyor

Göndermeye çalışıyorsa koda if ile 0 ise yada boş ise yada formüllü ise diye koşul eklenir.
O konu için extra konu açın bakalım abey.

---

Resimlerde gösterdim.


https://resim.accesstr.net/do.php?img=11043


https://resim.accesstr.net/do.php?img=11044


https://resim.accesstr.net/do.php?img=11045


https://resim.accesstr.net/do.php?img=11046

Sub Whatsap_ekle_sil_guncelle()



Dim dic As Object, sonAna As Long, keyy As String, kac As Long

Dim syfAna As Worksheet, dizi(), i As Long, say As Long, hatalimi As Boolean



Set dic = CreateObject("Scripting.dictionary")

Set syfAna = ThisWorkbook.Worksheets("Ana_Sayfa")



Application.ScreenUpdating = False

sonAna = syfAna.Range("A:A").Find("*", , , , , xlPrevious).Row

hatalimi = False



With ThisWorkbook.Worksheets("WHATSAPP")

  .Unprotect "171717"

    .Range("A2:A" & Rows.Count).ClearContents

    

    If sonAna < 2 Then

        hatalimi = True: GoTo son

    End If



    kac = WorksheetFunction.CountA(syfAna.Range("A2:A" & Rows.Count))

    If kac = 1 Then

        .Range("A2").Value = syfAna.Cells(sonAna, "AD").Value

        GoTo son

    End If

    

    dizi = syfAna.Range("AD2:AD" & sonAna).Value

    ReDim arr(1 To UBound(dizi), 1 To 1)

    say = 0

    

    For i = LBound(dizi) To UBound(dizi)

      keyy = CStr(dizi(i, 1))

      If Not dic.exists(keyy) Then

          say = say + 1

          dic.Add keyy, 0

          arr(say, 1) = keyy

      End If

    Next

    

    If dic.Count > 0 Then .Range("A2").Resize(dic.Count, 1).Value = arr

son:

Application.ScreenUpdating = True

.Protect "171717"

End With

On Error Resume Next

If hatalimi = True Then

    MsgBox "Kaydedilecek yada güncellenecek yada silinecek veri yok.", vbCritical, "Hata"

Else

    MsgBox "islem tamam.", vbInformation, "Bilgi"

End If

Set sic = Nothing: Set syfAna = Nothing: Erase arr: Erase dizi

End Sub

Boş veriler aktarmasın istiyorsanız ilgili yeri attaki gibi değiştirin.

If keyy <> "" Then ekledim koda ve end if
Ado ilede kısa kod ile yapılır.

    For i = LBound(dizi) To UBound(dizi)

        keyy = CStr(dizi(i, 1))

        If keyy <> "" Then

            If Not dic.exists(keyy) Then

                say = say + 1

                dic.Add keyy, 0

                arr(say, 1) = keyy

            End If

        End If

    Next

---

Kodun tamamı altta.

Sub Whatsap_ekle_sil_guncelle()



Dim dic As Object, sonAna As Long, keyy As String, kac As Long

Dim syfAna As Worksheet, dizi(), i As Long, say As Long, hatalimi As Boolean



Set dic = CreateObject("Scripting.dictionary")

Set syfAna = ThisWorkbook.Worksheets("Ana_Sayfa")



Application.ScreenUpdating = False

sonAna = syfAna.Range("A:A").Find("*", , , , , xlPrevious).Row

hatalimi = False





With ThisWorkbook.Worksheets("WHATSAPP")

  .Unprotect "171717"

    .Range("A2:A" & Rows.Count).ClearContents

    

    If sonAna < 2 Then

        hatalimi = True: GoTo son

    End If



    kac = WorksheetFunction.CountA(syfAna.Range("A2:A" & Rows.Count))

    If kac = 1 Then

        .Range("A2").Value = syfAna.Cells(sonAna, "AD").Value

        GoTo son

    End If

    

    dizi = syfAna.Range("AD2:AD" & sonAna).Value

    ReDim arr(1 To UBound(dizi), 1 To 1)

    say = 0

    

    For i = LBound(dizi) To UBound(dizi)

        keyy = CStr(dizi(i, 1))

        If keyy <> "" Then

            If Not dic.exists(keyy) Then

                say = say + 1

                dic.Add keyy, 0

                arr(say, 1) = keyy

            End If

        End If

    Next

    

    If say > 0 Then .Range("A2").Resize(say, 1).Value = arr

son:

Application.ScreenUpdating = True

.Protect "171717"

End With

On Error Resume Next

If hatalimi = True Then

    MsgBox "Kaydedilecek yada güncellenecek yada silinecek veri yok.", vbCritical, "Hata"

Else

    MsgBox "islem tamam.", vbInformation, "Bilgi"

End If

Set sic = Nothing: Set syfAna = Nothing: Erase arr: Erase dizi

End Sub

Buda Ado ile.

Sub Whatsap_ekle_sil_guncelle()



Dim syfAna As Worksheet, hatalimi As Boolean

Dim baglan As Object, rs As Object



Set baglan = CreateObject("adodb.connection")

Set rs = CreateObject("adodb.recordset")



Set syfAna = ThisWorkbook.Worksheets("Ana_Sayfa")



Application.ScreenUpdating = False

sonAna = syfAna.Range("A:A").Find("*", , , , , xlPrevious).Row

hatalimi = False





With ThisWorkbook.Worksheets("WHATSAPP")

  .Unprotect "171717"

    .Range("A2:A" & Rows.Count).ClearContents

    

    If sonAna < 2 Then

        hatalimi = True: GoTo son

    End If



    kac = WorksheetFunction.CountA(syfAna.Range("A2:A" & Rows.Count))

    If kac = 1 Then

        .Range("A2").Value = syfAna.Cells(sonAna, "AD").Value

        GoTo son

    End If

    

  baglan.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.FullName & _

    ";extended properties=""excel 12.0;hdr=yes"""

      rs.Open "select [WHATSAPP NO] from [Ana_Sayfa$] where [WHATSAPP NO]<>' '", baglan, 1, 1

      If rs.RecordCount > 0 Then .Range("A2").CopyFromRecordset rs

son:

Application.ScreenUpdating = True

.Protect "171717"

End With

On Error Resume Next

If hatalimi = True Then

    MsgBox "Kaydedilecek yada güncellenecek yada silinecek veri yok.", vbCritical, "Hata"

Else

    MsgBox "islem tamam.", vbInformation, "Bilgi"

End If

Set sic = Nothing: Set syfAna = Nothing: Erase arr: Erase dizi

rs.Close

baglan.Close

Set rs = Nothing

Set baglan = Nothing

End Sub