Soru E-Fatura Numarası sıralama

[NADİR YILDIZ]

Arkadaşlar A sütununda değişik serilere ait e-fatura numaraları var liste oldukça uzun.yapmak istediğim A sütunundaki ft numaralarını farklı seri numaralarına göre mavi sütünlarda ayrı ayrı sıralatırken mavi alanda sütunlarda sıralanmış olan ft ların aralarındaki eksik olan ft numaralarını da sarı sütunda sıralatmak istiyorum.yani kısacası a sütunundaki eksik ft ları sarı sütunlarda sıralatarak eksikleri bulmak istiyorum.

 

[halit3]

Bu kodu bir dene

Sub Gruplandir()

Range("C2:H" & Rows.Count).ClearContents
son1 = Cells(Rows.Count, "a").End(3).Row

ReDim ara1(son1): ReDim ara2(son1):

For j = 1 To son1

ara1(j) = Left((Cells(j, "a")), 7)
ara2(j) = 1
Next j

sut = 2
For r = 1 To son1
aranan1 = ara1(r)


If ara2(r) = 1 Then
sut = sut + 1
sat1 = 2

For i = r To son1
If ara1(i) = aranan1 Then

Cells(sat1, sut).Value = Cells(i, "A")
sat1 = sat1 + 1
ara2(i) = 0
End If
Next i


End If
Next r

Gruplandir2
End Sub


Sub Gruplandir2()

Range("j2:o" & Rows.Count).ClearContents

sut = 9
For r = 3 To 8
sut = sut + 1
sat1 = 2

If Cells(2, r).Value <> "" Then
sayi = Val(Right(Cells(2, r).Value, 9))
deg = Left(Cells(2, r).Value, 7)

For i = 2 To Cells(Rows.Count, r).End(3).Row
If Val(Right(Cells(i, r).Value, 9)) <> sayi Then
Cells(sat1, sut).Value = deg & Format(sayi, "000000000")
sayi = sayi + 1
sat1 = sat1 + 1
End If
sayi = sayi + 1

Next i

End If
Next r

MsgBox "İşleminiz tamamlanmıştır."

End Sub

 

[NADİR YILDIZ]

Sayın halit günaydın
öncelikle yardımınız için teşekkür ederim.
ancak bazı yerlerde hatalar tespit ettim.
ilk olarak a sütunundaki e-ft numaraları karışık geliyor bunları mavi alanda sıralatmak mümkün değil mi ? burada karışık listelenmiş
yeşil ile işaretlediğim hücrelerde ft'lar olmasına rağmen eksik olarak listeliyor.
VG12019000002396 ile VG12019000002399 arasındaki eksik ft ları listelemiyor.
seri 2 ve seri 3 ft larda sorun yok sanırım orda ft'ların numarası sıralı olduğu için sorun çıkarmıyor.
dediğim gibi ft sıraları karışık geliyor bunları mavi alanda sıralatarak sarı alanda eksikleri listelemek istiyorum.

 

[halit3]

koda kırmızı bölümü ekledim

Sub Düğme1_Tıklat()
Range("C2:H" & Rows.Count).ClearContents
son1 = Cells(Rows.Count, "a").End(3).Row

ReDim ara1(son1): ReDim ara2(son1):

For j = 1 To son1

ara1(j) = Left((Cells(j, "a")), 7)
ara2(j) = 1
Next j

sut = 2
For r = 1 To son1
aranan1 = ara1(r)


If ara2(r) = 1 Then
sut = sut + 1
sat1 = 2

For i = r To son1
If ara1(i) = aranan1 Then

Cells(sat1, sut).Value = Cells(i, "A")
sat1 = sat1 + 1
ara2(i) = 0
End If
Next i


End If
Next r


For j = 3 To 8
If Cells(2, j).Value <> "" Then
son = Cells(Rows.Count, j).End(xlUp).Row
Range(Cells(2, j), Cells(son, j)).Sort Key1:=Cells(2, j), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End If
Next j


Gruplandir2
End Sub


Sub Gruplandir2()

Range("j2:o" & Rows.Count).ClearContents

sut = 9
For r = 3 To 8
sut = sut + 1
sat1 = 2

If Cells(2, r).Value <> "" Then
sayi = Val(Right(Cells(2, r).Value, 9))
deg = Left(Cells(2, r).Value, 7)

For i = 2 To Cells(Rows.Count, r).End(3).Row
atla:
If Val(Right(Cells(i, r).Value, 9)) <> sayi Then
Cells(sat1, sut).Value = deg & Format(sayi, "000000000")
sayi = sayi + 1
sat1 = sat1 + 1
GoTo atla
End If
sayi = sayi + 1

Next i

End If
Next r

MsgBox "İşleminiz tamamlanmıştır."

End Sub

 

[NADİR YILDIZ]

sayın halit

mavi alanda sıralama yapıyor
ancak aşağıdaki sorun devam ediyor
VG12019000002388 VG12019000002399 arasında eksik ft ları listelememiş son ft listeliyor VG12019000002399
VGY2019000000185 VGY2019000000190 arasında eksik ft ları listelememiş son ft listeliyor VGY2019000000190

 

[halit3]

ben kodu yeniden güncellemiştim kırmızı bölüme baktınmı
goto atla bölümü

 

[NADİR YILDIZ]

Baktım o kodu kopyalayıp yenileyip gönderdim dosyayı zaten
dosya ekte uygularsan dediğim sorun devam ediyor

 

[halit3]

siz yine değiştirdiğim kodları görmemişsiniz altlara doğru bakın
kırmızı bunlar olacak
atla:
GoTo atla

 

[halit3]

eklediğiniz dosyada sonradan düzelttiğim bölümler yok

 

[NADİR YILDIZ]

şimdi oldu teşekkürler

 

[halit3]

Teşekkürler iyi çalışmalar

 

[igultekin2000]

Teşekkürler iyi çalışmalar

iyi akşamlar;
güzel bir çalıma olmuş, hem e-fatura, hem de kağıt fatura olduğunda denemek istediğimde sorun oluyor, şöyleki fatura numaları numaratik 125250, 125251 gibi listelemek isteğimde e -fatura olmayan numaraları yan yana listeliyor, yani farklı seri gibi işlem yapıyor bunun çözümü olabilir mi

 

[halit3]

iyi akşamlar;
güzel bir çalıma olmuş, hem e-fatura, hem de kağıt fatura olduğunda denemek istediğimde sorun oluyor, şöyleki fatura numaları numaratik 125250, 125251 gibi listelemek isteğimde e -fatura olmayan numaraları yan yana listeliyor, yani farklı seri gibi işlem yapıyor bunun çözümü olabilir mi

Merhaba bir çok mesajın olmuş buradaki uygulama farklı bir uygulama çözüm arıyorsanız örnek dosyanızı ekleyiniz bizim buradan sizin dosyanızı bilmemizin imkanı yok.

 

[NADİR YILDIZ]

sayın halit günaydın
igültekin arkadaşımızın aklındaki soruya ilişkin örnek dosyayı ekledim.
hem e-ft hemde normal ft numarası olduğunda ne yapabiliriz diyor.benim örneğimde ekleme yaptım.
aslında sayın igültekinin sorusu yerinde olmuş
bu konuda yardım eder misiniz
iyi çalışmalar

 

[NADİR YILDIZ]

sayın halit bununla ilgili yardımcı olurmusunuz

 

[halit3]

Bu şi birazcık karışık oldu galiba bu kodu bir deneyiniz

Sub Düğme1_Tıklat()
Range("C2:H" & Rows.Count).ClearContents
son1 = Cells(Rows.Count, "a").End(3).Row

ReDim ara1(son1): ReDim ara2(son1):

For j = 1 To son1
If Len(Cells(j, "a")) = 16 Then
ara1(j) = Left((Cells(j, "a")), 7)
Else

ara1(j) = Left((Cells(j, "a")), 2)

'ara1(j) = Cells(j, "a")
End If
ara2(j) = 1
Next j

sut = 2
For r = 1 To son1
aranan1 = ara1(r)


If ara2(r) = 1 Then
sut = sut + 1
sat1 = 2

For i = r To son1
If ara1(i) = aranan1 Then

Cells(sat1, sut).Value = Cells(i, "A")
sat1 = sat1 + 1
ara2(i) = 0
End If
Next i


End If
Next r


For j = 3 To 8
If Cells(2, j).Value <> "" Then
son = Cells(Rows.Count, j).End(xlUp).Row
Range(Cells(2, j), Cells(son, j)).Sort Key1:=Cells(2, j), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End If
Next j


Gruplandir2
End Sub

Sub Gruplandir2()

Range("j2:o" & Rows.Count).ClearContents

sut = 9
For r = 3 To 8
sut = sut + 1
sat1 = 2

If Cells(2, r).Value <> "" Then
sayi = Val(Right(Cells(2, r).Value, 9))
sayi2 = Cells(2, r).Value
deg = Left(Cells(2, r).Value, 7)

sayi3 = Val(Right(Cells(2, r).Value, 5))
deg2 = Left(Cells(2, r).Value, 2)


For i = 2 To Cells(Rows.Count, r).End(3).Row

atla:
If Len(Cells(i, r).Value) = 16 Then
If Val(Right(Cells(i, r).Value, 9)) <> sayi Then

Cells(sat1, sut).Value = deg & Format(sayi, "000000000")
sayi = sayi + 1
sat1 = sat1 + 1
GoTo atla
End If
Else

If Len(Cells(i, r).Value) = 6 Then
If Cells(i, r).Value <> sayi2 Then
Cells(sat1, sut).Value = sayi2
sayi2 = sayi2 + 1
sat1 = sat1 + 1
GoTo atla
End If
End If

If Len(Cells(i, r).Value) = 7 Then

If Val(Right(Cells(i, r).Value, 5)) <> sayi3 Then
deg2 = Left(Cells(i, r).Value, 2)
Cells(sat1, sut).Value = deg2 & Format(sayi3, "00000")
sayi3 = sayi3 + 1
sat1 = sat1 + 1
GoTo atla
End If
End If



End If
sayi = sayi + 1
If Len(Cells(2, r).Value) = 6 Then
sayi2 = sayi2 + 1

End If
If Len(Cells(2, r).Value) = 7 Then

sayi3 = sayi3 + 1
End If

Next i

End If
Next r

MsgBox "İşleminiz tamamlanmıştır."

End Sub

 

[halit3]

Burada sutünlarıda arttırmak gerekebilir.

 

[NADİR YILDIZ]

Evet sayın halit dediğiniz gibi
ft serisi arttıkça sütunlarda yetmiyor

 

[NADİR YILDIZ]

şimdilik bu işimi görüyor fazla seri olursa yardımınızı isterim
yardımcı olduğunuz için teşekkürler
iyi çalışmalar

 

[halit3]

Bu kodu bir dene sutunları silip kendisi oluşturuyor.

Dim sut

Sub Düğme1_Tıklat()

Columns("C:AZ").Delete Shift:=xlToLeft
'Range("C1:W" & Rows.Count).ClearContents
son1 = Cells(Rows.Count, "a").End(3).Row

ReDim ara1(son1): ReDim ara2(son1):

For j = 1 To son1
If Len(Cells(j, "a")) = 16 Then
ara1(j) = Left((Cells(j, "a")), 7)
Else

ara1(j) = Left((Cells(j, "a")), 2)

'ara1(j) = Cells(j, "a")
End If
ara2(j) = 1
Next j

sut = 2
For r = 1 To son1
aranan1 = ara1(r)


If ara2(r) = 1 Then

sut = sut + 1
Cells(1, sut).Value = "SERİ " & sut - 2 & " - SIRALAMA"
Cells(1, sut).Interior.ColorIndex = 4
Cells(1, sut).Font.ColorIndex = 3



sat1 = 2

For i = r To son1
If ara1(i) = aranan1 Then

Cells(sat1, sut).Value = Cells(i, "A")
Cells(sat1, sut).Interior.ColorIndex = 8


sat1 = sat1 + 1
ara2(i) = 0
End If
Next i


End If
Next r


For j = 3 To sut
If Cells(2, j).Value <> "" Then
son = Cells(Rows.Count, j).End(xlUp).Row
Range(Cells(2, j), Cells(son, j)).Sort Key1:=Cells(2, j), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End If
Next j


Gruplandir2
End Sub

Sub Gruplandir2()

'Range("j2:o" & Rows.Count).ClearContents
sut2 = sut + 1
'sut = 13
For r = 3 To sut
sut2 = sut2 + 1

Cells(1, sut2).Value = "SERİ " & r - 2 & " - EKSİK"
Cells(1, sut2).Interior.ColorIndex = 4
Cells(1, sut2).Font.ColorIndex = 3
sat1 = 2

If Cells(2, r).Value <> "" Then
sayi = Val(Right(Cells(2, r).Value, 9))
sayi2 = Cells(2, r).Value
deg = Left(Cells(2, r).Value, 7)

sayi3 = Val(Right(Cells(2, r).Value, 5))
deg2 = Left(Cells(2, r).Value, 2)


For i = 2 To Cells(Rows.Count, r).End(3).Row

atla:
If Len(Cells(i, r).Value) = 16 Then
If Val(Right(Cells(i, r).Value, 9)) <> sayi Then

Cells(sat1, sut2).Value = deg & Format(sayi, "000000000")

Cells(sat1, sut2).Interior.ColorIndex = 6

sayi = sayi + 1
sat1 = sat1 + 1
GoTo atla
End If
Else

If Len(Cells(i, r).Value) = 6 Then
If Cells(i, r).Value <> sayi2 Then
Cells(sat1, sut2).Value = sayi2
Cells(sat1, sut2).Interior.ColorIndex = 6
sayi2 = sayi2 + 1
sat1 = sat1 + 1
GoTo atla
End If
End If

If Len(Cells(i, r).Value) = 7 Then

If Val(Right(Cells(i, r).Value, 5)) <> sayi3 Then
deg2 = Left(Cells(i, r).Value, 2)
Cells(sat1, sut2).Value = deg2 & Format(sayi3, "00000")
Cells(sat1, sut2).Interior.ColorIndex = 6
sayi3 = sayi3 + 1
sat1 = sat1 + 1
GoTo atla
End If
End If



End If
sayi = sayi + 1
If Len(Cells(2, r).Value) = 6 Then
sayi2 = sayi2 + 1

End If
If Len(Cells(2, r).Value) = 7 Then

sayi3 = sayi3 + 1
End If

Next i

End If
Next r

Columns("C:AZ").EntireColumn.AutoFit

MsgBox "İşleminiz tamamlanmıştır."

End Sub