RE: Excel Vba Da Veri Kaydederken Diğer Sayfaya Kopyasını Almak. - feraz - 16/05/2021
Ö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
RE: Excel Vba Da Veri Kaydederken Diğer Sayfaya Kopyasını Almak. - Oğuz Türkyılmaz - 16/05/2021
(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.
RE: Excel Vba Da Veri Kaydederken Diğer Sayfaya Kopyasını Almak. - feraz - 16/05/2021
(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.
RE: Excel Vba Da Veri Kaydederken Diğer Sayfaya Kopyasını Almak. - feraz - 16/05/2021
(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
Re: Excel Vba Da Veri Kaydederken Diğer Sayfaya Kopyasını Almak. - feraz - 16/05/2021
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
|