• DİKKAT !

    Forum içeriğine ve tüm hizmetlerimize erişim sağlamak için foruma kayıt olmalı ya da giriş yapmalısınız. Foruma üye olmak Dosya Yükleme tamamen ücretsizdir.

Çözüldü Userform ile excele çoklu aktarım yapma

  • Konuyu Başlatan Konuyu Başlatan Excel005
  • Başlangıç tarihi Başlangıç tarihi
  • Görüntülenme 502
Bu konu çözüldü olarak işaretlenmiştir. Çözülmediğini düşünüyorsanız konuyu rapor edebilirsiniz.
Durum
Konu Çözümlendiği İçin Kapatılmıştır.

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
 
bir önceki konunuzda kodda yaptığım değişiklikleri ve eklemelerin aynısını buradaki kodda da yapmanız yeterli
 
Çözüm
Durum
Konu Çözümlendiği İçin Kapatılmıştır.
Geri
Üst