Excel005
Yeni Üye
- Katılım
- 28 Mar 2023
- Mesajlar
- 44
- Aldığı beğeni
- 5
- Excel V
- Office 2010 TR
Konu Sahibi
Merhaba, aşağıdaki kodu daha önce site yardımıyla oluşturmuştuk. Normalde kodda dz = Split(metin, "FPL-") ile belirtilen " FPL-" ile başlayan metinler kullanıyordum, ama ihtiyaç üzerine "CHG-", "DLA-", "CNL-" verilerini de almaya başladık. Böyle olunca kod "FPL-" ile başlayan verilere bakıyor ama filtrelerle atlanması gereken bir metin olduğunda, sonrasında mesela "CHG-" metni gelince bunu bütünleşik algılıyor ve bu bütünleşik hatalı metni excele atıyor. Bu çok nadir olduğu için bu hatanın sebebini anlamamız uzun sürdü. Kodda "FPL-" ye ek olarak "CHG-" de eklemek mümkün mü? Yani excele "FPL-" yi aktarırken hangi adımlar varsa aynı adımları "CHG-" için de uygulasın. Diğer "DLA-", "CNL-" mesajlarını görünce excele aktarmadan atlasın, örneğin önce "FPL-" sonra "DLA-" sonrasında "FPL-" geliyorsa, "DLA-" yı atlayıp sadece "FPL-" leri excele aktarsın. Tüm metinler "(" başlayıp, metinler ")" ile bitiyor, kodda düzenleme yapılıp metinlerin başlangıç ve bitişleri için "(" ve ")" kullanılabilir. Şimdiden yardımcı olarak uzman arkadaşlara teşekkür ederim. İyi günler.
-----------------------------Örnek aktarılan metin-----------------------------
(FPL-ABC123-IN -F100/M-SRWY/C -LPPR0600 -N0422F340 TURON
UP600 STG UN741 KEPER -WXYZ0155 -DOF/230403
REG/ZZ115 EET/LPPR0020)
(CHG-ABC256-IN -F100/M-SRWY/C -WXYZ0600 -N0422F340 TURON
UP600 STG UN741 KEPER -LFPG0155 -DOF/230404
REG/ZZ212 EET/LPPR0020)
(FPL-ABC368-IN -F100/M-SRWY/C -WXYZ0600 -N0422F340 TURON
UP600 STG UN741 KEPER -LFPG0155 -DOF/230405
REG/ZZ321 EET/LPPR0020)
(CHG-ABC479-IN -F100/M-SRWY/C -LPPR0600 -N0422F340 TURON
UP600 STG UN741 KEPER -WXYZ0155 -DOF/230406
REG/ZZ415 EET/LPPR0020)
(CNL-ABC585-LPPR0600-WXYZ0155-DOF/230407)
(FPL-ABC689-IN -F100/M-SRWY/C -WXYZ0600 -N0422F340 TURON
UP600 STG UN741 KEPER -LFPG0155 -DOF/230408
REG/ZZ612 EET/LPPR0020)
(DLA-ABC762-WXYZ0600-LFPG0155 -DOF/230409)
Excele aktarılacak veriler: ABC123,ABC256,ABC368,ABC479,ABC689
Excele aktarılmayacak veriler:ABC585,ABC762
-------------------günlere göre excele aktaran kod-----------------------------------
Private Sub CommandButton1_Click()
'On Error GoTo son
metin = Replace(Replace(" " & TextBox1.Text, Chr(10), " "), Chr(13), " ")
Dz = Split(metin, "FPL-")
xSay = UBound(Dz)
Dim dzS() As Variant: ReDim dzS(1 To xSay, 1)
Dim dzK_AB() As Variant
Dim xDz(1 To 7, 1) As Variant
Dim xSon(1 To 7, 1) As Variant
For xGun = 1 To 7
son = ThisWorkbook.Worksheets("sayfa" & xGun).Cells(Rows.Count, "A").End(3).Row
DzxL = ThisWorkbook.Worksheets("sayfa" & xGun).Range("A2:B" & son).Value
ReDim dzK_AB(1 To son + xSay - 1)
For x = 1 To son - 1
dzK_AB(x) = Trim(DzxL(x, 1)) & "|" & Trim(DzxL(x, 2))
Next x
xSon(xGun, 0) = 0
xSon(xGun, 1) = son + 1
xDz(xGun, 0) = dzK_AB
xDz(xGun, 1) = dzS
Next xGun
For x = 1 To xSay
metin = Dz(x)
s2 = InStr(metin, "-")
mA = Trim(Left(metin, s2 - 1))
xV = (Mid(metin, s2, 2) = "-V")
xIM = (Mid(metin, s2, 3) = "-IM")
If Not IsError(Application.Match(Left(mA, 3), Array("EEE", "DDD", "FFF", "GGG"), False)) Or xV Then GoTo xAtla
If Not IsError(Application.Match(Left(mA, 2), Array("HH"), False)) Or xIM Then GoTo xAtla
sTrh = InStr(1, metin, "DOF/")
mTrh = Trim(Mid(metin, sTrh + 4, 6))
mTrh = Right(mTrh, 2) & "." & Mid(mTrh, 3, 2) & "." & Left(mTrh, 2)
mTrh = Weekday(CDate(mTrh), 2)
dzK_AB = xDz(mTrh, 0)
wx = InStr(1, metin, "-WXYZ"): If wx = 0 Then GoTo xAtla
s1 = InStr(1, metin, "REG/"): If s1 = 0 Then GoTo xAtla
s2 = InStr(s1, metin, " ")
mB = Trim(Mid(metin, s1 + 4, s2 - s1 - 4))
If Not IsError(Application.Match(mA & "|" & mB, dzK_AB, False)) Then GoTo xAtla
xSon(mTrh, 0) = xSon(mTrh, 0) + 1
xY = xSon(mTrh, 0)
son = xSon(mTrh, 1)
xDz(mTrh, 1)(xY, 0) = mA
xDz(mTrh, 1)(xY, 1) = mB
dzK_AB(son + xY - 2) = mA & "|" & mB
xDz(mTrh, 0) = dzK_AB
xAtla:
Next x
Debug.Print
For xGun = 1 To 7
son = xSon(xGun, 1)
xY = xSon(xGun, 0)
dzS = xDz(xGun, 1)
If xY > 0 Then ThisWorkbook.Worksheets("sayfa" & xGun).Range("A" & son).Resize(xY, 2) = dzS
Next xGun
TextBox1.Text = Empty
'MsgBox "Bitti"
Exit Sub
son:
MsgBox "Kelimelerde olmayan değerler oluştu kontrol ediniz", vbCritical, "DİKKAT"
End Sub
-----------------------------Örnek aktarılan metin-----------------------------
(FPL-ABC123-IN -F100/M-SRWY/C -LPPR0600 -N0422F340 TURON
UP600 STG UN741 KEPER -WXYZ0155 -DOF/230403
REG/ZZ115 EET/LPPR0020)
(CHG-ABC256-IN -F100/M-SRWY/C -WXYZ0600 -N0422F340 TURON
UP600 STG UN741 KEPER -LFPG0155 -DOF/230404
REG/ZZ212 EET/LPPR0020)
(FPL-ABC368-IN -F100/M-SRWY/C -WXYZ0600 -N0422F340 TURON
UP600 STG UN741 KEPER -LFPG0155 -DOF/230405
REG/ZZ321 EET/LPPR0020)
(CHG-ABC479-IN -F100/M-SRWY/C -LPPR0600 -N0422F340 TURON
UP600 STG UN741 KEPER -WXYZ0155 -DOF/230406
REG/ZZ415 EET/LPPR0020)
(CNL-ABC585-LPPR0600-WXYZ0155-DOF/230407)
(FPL-ABC689-IN -F100/M-SRWY/C -WXYZ0600 -N0422F340 TURON
UP600 STG UN741 KEPER -LFPG0155 -DOF/230408
REG/ZZ612 EET/LPPR0020)
(DLA-ABC762-WXYZ0600-LFPG0155 -DOF/230409)
Excele aktarılacak veriler: ABC123,ABC256,ABC368,ABC479,ABC689
Excele aktarılmayacak veriler:ABC585,ABC762
-------------------günlere göre excele aktaran kod-----------------------------------
Private Sub CommandButton1_Click()
'On Error GoTo son
metin = Replace(Replace(" " & TextBox1.Text, Chr(10), " "), Chr(13), " ")
Dz = Split(metin, "FPL-")
xSay = UBound(Dz)
Dim dzS() As Variant: ReDim dzS(1 To xSay, 1)
Dim dzK_AB() As Variant
Dim xDz(1 To 7, 1) As Variant
Dim xSon(1 To 7, 1) As Variant
For xGun = 1 To 7
son = ThisWorkbook.Worksheets("sayfa" & xGun).Cells(Rows.Count, "A").End(3).Row
DzxL = ThisWorkbook.Worksheets("sayfa" & xGun).Range("A2:B" & son).Value
ReDim dzK_AB(1 To son + xSay - 1)
For x = 1 To son - 1
dzK_AB(x) = Trim(DzxL(x, 1)) & "|" & Trim(DzxL(x, 2))
Next x
xSon(xGun, 0) = 0
xSon(xGun, 1) = son + 1
xDz(xGun, 0) = dzK_AB
xDz(xGun, 1) = dzS
Next xGun
For x = 1 To xSay
metin = Dz(x)
s2 = InStr(metin, "-")
mA = Trim(Left(metin, s2 - 1))
xV = (Mid(metin, s2, 2) = "-V")
xIM = (Mid(metin, s2, 3) = "-IM")
If Not IsError(Application.Match(Left(mA, 3), Array("EEE", "DDD", "FFF", "GGG"), False)) Or xV Then GoTo xAtla
If Not IsError(Application.Match(Left(mA, 2), Array("HH"), False)) Or xIM Then GoTo xAtla
sTrh = InStr(1, metin, "DOF/")
mTrh = Trim(Mid(metin, sTrh + 4, 6))
mTrh = Right(mTrh, 2) & "." & Mid(mTrh, 3, 2) & "." & Left(mTrh, 2)
mTrh = Weekday(CDate(mTrh), 2)
dzK_AB = xDz(mTrh, 0)
wx = InStr(1, metin, "-WXYZ"): If wx = 0 Then GoTo xAtla
s1 = InStr(1, metin, "REG/"): If s1 = 0 Then GoTo xAtla
s2 = InStr(s1, metin, " ")
mB = Trim(Mid(metin, s1 + 4, s2 - s1 - 4))
If Not IsError(Application.Match(mA & "|" & mB, dzK_AB, False)) Then GoTo xAtla
xSon(mTrh, 0) = xSon(mTrh, 0) + 1
xY = xSon(mTrh, 0)
son = xSon(mTrh, 1)
xDz(mTrh, 1)(xY, 0) = mA
xDz(mTrh, 1)(xY, 1) = mB
dzK_AB(son + xY - 2) = mA & "|" & mB
xDz(mTrh, 0) = dzK_AB
xAtla:
Next x
Debug.Print
For xGun = 1 To 7
son = xSon(xGun, 1)
xY = xSon(xGun, 0)
dzS = xDz(xGun, 1)
If xY > 0 Then ThisWorkbook.Worksheets("sayfa" & xGun).Range("A" & son).Resize(xY, 2) = dzS
Next xGun
TextBox1.Text = Empty
'MsgBox "Bitti"
Exit Sub
son:
MsgBox "Kelimelerde olmayan değerler oluştu kontrol ediniz", vbCritical, "DİKKAT"
End Sub
Ekli dosyalar
Bu konu çözüme ulaşmıştır yüklü dosyaları indirmek için Bronz üye olunuz.
Bu dosyayı indirmek için yetkiniz bulunmamaktadır.