(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ş farketmiyorGö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
NextKodun 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
