Verileri saydırma

[aydgur]

Sub verileri_benzersiz_saydırma_vadeleri()

Dim sh As Worksheet, ss As Long, z As Object, a, b(), i As Long, n As Long
Dim aranan As String

Set sh = Sheets("VADE")
ss = sh.Range("C" & Rows.Count).End(3).Row
Set z = CreateObject("Scripting.Dictionary")
z.comparemode = vbTextCompare
ReDim b(1 To 3, 1 To 1)
n = 0
a = sh.Range("A2:b" & ss).Value
For i = 1 To UBound(a, 1)
If a(i, 1) <> "" Then
aranan = a(i, 1)
If Not z.exists(aranan) Then
n = n + 1
z.Add aranan, n
ReDim Preserve b(1 To 3, 1 To n)
b(1, n) = a(i, 1)
b(2, n) = a(i, 2) * 1

Else
b(2, z.Item(aranan)) = b(2, z.Item(aranan)) * 1 + a(i, 2) * 1

End If
End If
Next i
sh.Range("H1").Value = "STOK ADI"
sh.Range("I1").Value = "SATIŞ KG"


sh.Range("H2:I" & Rows.Count).ClearContents
sh.Range("H2:I" & Rows.Count).Borders.LineStyle = xlNone
sh.Range("H2").Resize(z.Count, 2).Value = Application.Transpose(b)
With sh.Range("H2:I1" & z.Count)
.Borders.LineStyle = 1
.Font.Name = "Calibri"
.Font.Size = 10
End With
MsgBox "İşlem tamamlandı.", vbInformation, "Aydın_Gürses"
End Sub
Forumda sizlerden aldığım yardım ile yapılan bu makroda A sütunundaki verileri H sütununa ve B sütunundaki verileride I sütununa getiriyordu .Şimdi B yerine E sütunundaki verileri getirmesi için kodun neresini değiştirmeliyim. Yardımcı olmanızı rica ederim.

 

[muhasebeciyiz]

Sub verileri_benzersiz_saydirma_vadeleri()

Dim sh As Worksheet, ss As Long, z As Object, a As Variant, b() As Variant, i As Long, n As Long
Dim aranan As String

Set sh = Sheets("VADE")
ss = sh.Range("C" & sh.Rows.Count).End(xlUp).Row ' Hatalı satır düzeltildi
Set z = CreateObject("Scripting.Dictionary")
z.comparemode = vbTextCompare
ReDim b(1 To 2, 1 To 1)
n = 0
a = sh.Range("A2:E" & ss).Value ' Bitiş sütunu E olacak şekilde güncellendi

For i = 1 To UBound(a, 1)
If a(i, 1) <> "" Then
aranan = a(i, 1)
If Not z.exists(aranan) Then
n = n + 1
z.Add aranan, n
ReDim Preserve b(1 To 2, 1 To n)
b(1, n) = a(i, 1)
b(2, n) = a(i, 5) * 1 ' E sütununu işaret edecek şekilde güncellendi
Else
b(2, z.Item(aranan)) = b(2, z.Item(aranan)) * 1 + a(i, 5) * 1 ' E sütununu işaret edecek şekilde güncellendi
End If
End If
Next i

sh.Range("H1").Value = "STOK ADI"
sh.Range("I1").Value = "SATIŞ KG"

sh.Range("H2:I" & sh.Rows.Count).ClearContents
sh.Range("H2:I" & sh.Rows.Count).Borders.LineStyle = xlNone

' Transpose işlemini güvenli hale getirmek için kontrol
If n > 0 Then
Dim tempArray() As Variant
ReDim tempArray(1 To 2, 1 To n)
For i = 1 To n
tempArray(1, i) = b(1, i)
tempArray(2, i) = b(2, i)
Next i
sh.Range("H2").Resize(n, 2).Value = Application.WorksheetFunction.Transpose(tempArray)
End If

With sh.Range("H2:I" & (n + 1)) ' Aralık doğru şekilde güncellendi
.Borders.LineStyle = 1
.Font.Name = "Calibri"
.Font.Size = 10
End With

MsgBox "İşlem tamamlandı.", vbInformation, "Aydın_Gürses"
End Sub

 

[cems]

...

 

[aydgur]

Çok teşekkür edwerim Fakat ss

ss = sh. Range("C" & Rows.Count). Bitiş(3). Satır Kümesi



hata verdi

 

[aydgur]

Böylebir hata verdi, ne yapabilirim ?