• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Belirli bir kurala göre parça alma

M

mustilem23

Katılım
29 Ekim 2010
Mesajlar
365
Excel Vers. ve Dili
Microsoft Office 365 ProPlus 64 bit
Merhaba
Ekte bulunan 2 tip durum için parça al fonksiyonu kullanarak macro ile yapılabileceğini düşündüğüm bir sorun var .

Satır ve sütunlar içinde belle bir kurala göre sayfaya aktarmak gibi yardımcı olabilir misiniz. Teşekkürler
 

Ekli dosyalar

Örnek 2 de,

Buradaki bilgiler ile aşağıdaki diğer bilgiler aynı yapıya sahip,

KLEMP SWICH TAKOZU (OTOMATIK KLEMP) 3509613220 2
klemp sviç yayı 3509612780 2
klemp sviç takoz civatası 3509612015 2

Siz sonuç sayfasında sadece alttaki yapıyı sonuca dahil etmişsiniz.

Program belli kriterlere göre çalışabilir, bu ayrımı neye göre yaptınız?

UST TARET TAKIMLARI GERI ITICI YAYI 3509611630 49
UST TARET D TAKIM KAMASI 3509611460 2
UST TARET C TAKIM KAMASI 3509611490 1
UST TARET INDEX C TAKIM KLAVUZLAMA KAMA 3509610920 1
UST TARET INDEX B TAKIM KLAVUZLAMA KAMA 3509610930 2
UST TARET A TAKIM KAMASI 3509611470 3
UST TARET B TAKIM KAMASI 3509611480 18
ALT TARET C INDEX TAKIM KLAVUZLAMA KAMA 3509611200 1
ALT TARET 201 216 NO TAKIM KLAVUZ KAMASI 3509610220 2


Ayrıca örnek 1 de ve örnek 2 aşağıdaki yapıda satırlar mevcut.
2 AD 3509611905
2 AD 3509611915
4 AD 3509611920
2 AD 3304300130

Örnek 1 de sonuç kısmına bunu dahil etmişsiniz. Ancak Örnek 2 de dahil etmemişsiniz.
Dahil edip etmeme kuralı nedir?
 
Üstadım buradaki durum hep aynı bu veriler outlook içinden kopyaladım verilerin bazıları satır ve sütun olarak geliyor ama onlarında malzeme no tanım adet şeklinde çeviriyorum bazılarına düz metin olarak envanter no ve adet olarak geliyor email de sonuçta ise bana gerekli olan envanter no ve adet yani üstad 2 koşul mevcut .olabilmesi mümkün müdür.
 
mustilem23' Alıntı:
Üstadım buradaki durum hep aynı bu veriler outlook içinden kopyaladım verilerin bazıları satır ve sütun olarak geliyor ama onlarında malzeme no tanım adet şeklinde çeviriyorum bazılarına düz metin olarak envanter no ve adet olarak geliyor email de sonuçta ise bana gerekli olan envanter no ve adet yani üstad 2 koşul mevcut .olabilmesi mümkün müdür.
Genişletmek için tıkla ...

Burada sorun ayırmak değil, belli bir koşula göre sonuç çıkarmak.

Soru şu şekilde olur ise çözüm olabilir.
Tüm envanter no ve adetleri listeleyebilir miyiz?
 
Haklısınız üstad. Evet tam olarak ihtiyacım budur.böyle birşey mümkünmüdür.
 
Text dosyadan okunacak şekilde deneyiniz.

Örnek veri dosyası ve dosya ektedir.
Bu verileri
1ad3507005011
2 ad 3507005012
3AD 3507005013
ad zımba 4 3507005014
ZIMBA 3507005015 5
6 ADET 3507005016
3507005017 ZIMBA ADET 7
AD8 3507005018
ad 3507005019 9
adet 3507005020 10
ADET 3507005021 11
3507005022 ZIMBA ADET 12
ZIMBA 3507005023 13
14 3507005024 ADET
AD 3507005025 14
ad zımba 15 3507005026
3507005027 16
17 3507005028
3507005029 ZIMBA ADET 18
3507005030 ZIMBA ADET 19


Bu şekilde listeleyecektir
Kod Adet
3507005011 1
3507005012 2
3507005013 3
3507005014 4
3507005015 5
3507005016 6
3507005017 7
3507005018 8
3507005019 9
3507005020 10
3507005021 11
3507005022 12
3507005023 13
3507005024 14
3507005025 14
3507005026 15
3507005027 16
3507005028 17
3507005029 18
3507005030 19

Kod: 
Public veriler(1000000, 3) As String
Dim txtdosya, verisay As Long
Dim readdata, yontem, readdataorg, veri As String
Dim satir As Long

Function dosyavarmi(dosya)
  Dim ds, a
  Set ds = CreateObject("Scripting.FileSystemObject")
  a = ds.FileExists(dosya)
  If a = True Then
    dosyavarmi = True
  Else
    dosyavarmi = False
  End If
End Function

Sub menu()
   ChDir ActiveWorkbook.Path
   txtdosya = Application.GetOpenFilename(("Text Dosyalar (*.txt), *.txt"), 1, "Text Dosya Seçiniz")

   If txtdosya = "" Then
       MsgBox ("İşlem iptal edildi.")
      Exit Sub
   End If
   
   Call temizle
   Call sifirla
   Call veri_temizle_dosyadan
   Call bilgi_al
End Sub

Sub sifirla()
  For i = 1 To 1000000
     veriler(verisay, 1) = ""
     veriler(verisay, 2) = ""
     veriler(verisay, 3) = ""
  Next i
End Sub

Sub veri_temizle_dosyadan()
  Set shmenu = Sheets("Menu")
  yol = ThisWorkbook.Path
  
  Dim readdata As String
    verisay = 0
    Open txtdosya For Input As #1
      Do Until EOF(1)
         verial = True
         Line Input #1, readdata
         readdata = Trim(readdata)
         readdata = Replace(readdata, Chr(9), " ")
         veri = Trim(readdata)
         
         If sadececizgimi(veri) Then
            verial = False
            GoTo son
         End If
         
         If Len(veri) <= 2 Then
            verial = False
            GoTo son
         End If

son:
         If verial Then
            verisay = verisay + 1
            veriler(verisay, 1) = tek_bosluk(readdata)
         End If
      Loop
    Close #1

 End Sub
 
Sub temizle()
    Sheets("Liste").Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    Range("A2:I" & sonsatir).Clear
    Range("A1").Select
    Sheets("Menu").Select
End Sub

Sub bilgi_al()
    Application.ScreenUpdating = False
    Set shliste = Sheets("Liste")
    Set shmenu = Sheets("MENU")
    
    Sheets("Liste").Select
    Range("F1").Select
    
    yol = ThisWorkbook.Path
    Dim readdata As String

    'listesatir = shliste.Cells(Rows.Count, "A").End(3).Row
    listesatir = 1
   
    For i = 1 To verisay
         readdata = veriler(i, 1)
         readdataorg = readdata
         readdata = kelimeayir(readdata)
         readdata = sayiayir(readdata)
         readdata = Trim(tek_bosluk(readdata))
         adet = ""
         kod = ""
         veri = readdata
         sayi1 = Mid(veri, 1, InStr(veri, " ") - 1)
         sayi2 = Mid(veri, InStr(veri, " ") + 1, Len(veri))
         kod = ""
         adet = ""
         If Len(sayi1) > Len(sayi2) Then
            kod = sayi1
            adet = sayi2
         End If
         
         If Len(sayi2) > Len(sayi1) Then
            kod = sayi2
            adet = sayi1
         End If
  
         If kod <> "" And adet <> "" Then
            listesatir = listesatir + 1
            shliste.Cells(listesatir, 1).Value = kod
            shliste.Cells(listesatir, 2).Value = adet
         End If
  Next i
End Sub

Function sadececizgimi(sadecesayistr)
  liste = "+=-_ /" & sayikabuletstr
  For k = 1 To Len(sadecesayistr)
    harf = Mid(sadecesayistr, k, 1)
    If InStr(liste, harf) <= 0 Then
       sadececizgimi = False
       Exit Function
    End If
  Next k
  sadececizgimi = True
End Function

Public Function tek_bosluk(cumle)
  gecici = ""
  eski = "99"
  If InStr(1, cumle, " ") > 0 Then
    For i2 = 1 To Len(cumle)
      h = Mid(cumle, i2, 1)
      If eski <> " " Then
        gecici = gecici + h
      ElseIf eski = " " And h <> " " Then
        gecici = gecici + h
      End If
      eski = h
    Next i2
    tek_bosluk = gecici
  Else
    tek_bosluk = cumle
  End If

End Function

Function kelimeayir(veristr) As String
  liste = "0123456789"
      yenistr = ""
      For k = 1 To Len(veristr)
        h = Mid(veristr, k, 1)
        durum = "x"
        If InStr(liste, h) > 0 Then durum = "s"
        If InStr(liste, h) = 0 Then durum = "h"
        If k = 1 Then oncekidurum = durum
        
        If durum = oncekidurum Then
           yenistr = yenistr & h
        Else
           yenistr = yenistr & " " & h
        End If
        oncekidurum = durum
      Next k
      kelimeayir = yenistr
End Function


Function sayiayir(veristr) As String
  liste = "0123456789"
  yenistr = ""
  For k = 1 To Len(veristr)
    h = Mid(veristr, k, 1)
    If InStr(liste, h) > 0 Or h = " " Then
       yenistr = yenistr & h
    End If
  Next k
  sayiayir = yenistr
End Function
 

Ekli dosyalar

Son düzenleme:
Oncelik ile Üstad emeğin için teşekkür ederim.hayırlı ramazanlar. Bugün işler epey yoğundu birkaç deneme yaptım süper. ????
Lakin asıl hedefime tam ulaşamadım aktarılan exceli autoit ile beraber çalıştırdım ama sheet ayarında ve hücrelerinden sıkıntıdan kaynaklı ilerleme yapamadım rica etsem autoit çalışma scriptime bir göz atabilirmisiniz teklif.xls iptal yerine servıs dosyası .xls 2. sayfa satır ve sütunları .yardımlarınız için şimdiden çok teşekkür ederim.

http://www.dosyaupload.com/dcXx

Çok hoş bir uygulama olacak benim için.
 
mustilem23' Alıntı:
.. autoit çalışma scriptime bir göz atabilirmisiniz teklif.xls iptal yerine servıs dosyası .xls 2. sayfa satır ve sütunları ..
Genişletmek için tıkla ...

yazdığınızdan hiç birşey anlamadım. :)

Bu kodların altına
Local $stok=$oExcel.activesheet.cells($i, 1).value
Local $adet=$oExcel.activesheet.cells($i, 3).value

bunu eklediğimde excel den okuma yaptığını görebiliyoruz.
MsgBox($MB_SYSTEMMODAL, "Okunan bilgi", "Stok : " & $stok & " adet : " & $adet )
exit

Bunu da kodun en başına ekleyin.
#include <MsgBoxConstants.au3>
 
Burayı denedim yazmadan önce fakat servıs dosyasından adlı excelw actirabildim fakat liste sayfasını actira madım liste sayfasinda n okuma yaptırabilirmiyiz .kodlar şuan aktif olan ilk menü sayfasını okuyabiliyor yardımcı olabilirmisiniz rica etsem.
 
mustilem23' Alıntı:
Burayı denedim yazmadan önce fakat servıs dosyasından adlı excelw actirabildim fakat liste sayfasını actira madım liste sayfasinda n okuma yaptırabilirmiyiz .kodlar şuan aktif olan ilk menü sayfasını okuyabiliyor yardımcı olabilirmisiniz rica etsem.
Genişletmek için tıkla ...

Buradaki (1) değerini 2 yada 3 yazarak deneyin.

$oExcel.Workbooks.Open (@ScriptDir & "\teklif.xlsx").Sheets (1).Select ()
 
Çok teşekkür ederim üstadım autoit istediğim excel ve sayfadan okuma yapıyor.
Notped için çeşitli denemeler yapıyorum halen konu hakkında ileri günlerde tekrar yazabilir miyim.
 
Alternatif olarak; örnek1 dosyanızda aşağıdaki kodları deneyebilirsiniz:
Sub duzenle()
Dim deg1 As Object, deg2 As Object, veri1 As Object, veri2 As Object
Dim sh As Worksheet, ss As Long

Set sh = Sheets("" & Sheets(1).Name & "")
ss = sh.Range("A" & Rows.Count).End(3).Row
Set deg1 = CreateObject("VBScript.RegExp")
Set deg2 = CreateObject("VBScript.RegExp")
deg1.Global = True
deg2.Global = True
deg1.Pattern = "^[\d]{1}"
deg2.Pattern = "[\d]+$"
For i = 1 To ss
Cells(i, "B").Value = deg1.Execute(Cells(i, "A")).Item(0)
Cells(i, "D").Value = deg2.Execute(Cells(i, "A")).Item(0)
Next i
MsgBox "İşleminiz tamamlandı.", vbInformation, sh.Name
End Sub
 
Sayın Antanio ilginiz için teşekkürler. Diğer örnek kuralları kapsayacak şekilde geliştirebilir mi acaba mümkün müdür.
 
Örnek2 dosyanız için denediğim kodların sonuçlarını gözlemek için A sütununda verileri silmeden B ve C sütunlarında göreceksiniz. Eğer bu kod işinize yararsa, sonuçlar A ve C sütunlarına uyarlanabilir:
Kod: 
Sub kelimeler()
Dim deg1 As Object, deg2 As Object
Dim sh As Worksheet, i As Integer

Set sh = Sheets(1)
Set deg1 = CreateObject("VBScript.RegExp")
Set deg2 = CreateObject("VBScript.RegExp")
deg1.Global = True
deg2.Global = True
deg1.Pattern = "^\d+"
deg2.Pattern = "\d+$"
For i = 1 To 3
    sh.Range("B" & i).Value = deg2.Execute(sh.Range("A" & i)).Item(0)
    sh.Range("C" & i).Value = deg1.Execute(sh.Range("A" & i)).Item(0)
Next i
End Sub
 
Sayın antonio denedim fakat 3 satıra işlem yapıyor.
Emaillerimi kontrol ettim oluşmuş varyasyonlara göre bir liste yaptım çalışmamıza bu listeyi baz alarak sonuca ulastirabilmek mümkünmüdür.
Asrı usta sizin makronuzda bu örnek listeyi size iletmmediğim için adet yazısı olursa hata alıyorum listeyi baz alarak macroyu düzenlemek mümkün müdür.
 

Ekli dosyalar

Bir bilgi bu kadar mı karışık gönderilir.

Sipariş aldığınız yerlere formatınızı bildirin. O şekilde göndersinler , işler daha kolaylaşır : )))
 
mustilem23' Alıntı:
Sayın antonio denedim fakat 3 satıra işlem yapıyor.
Emaillerimi kontrol ettim oluşmuş varyasyonlara göre bir liste yaptım çalışmamıza bu listeyi baz alarak sonuca ulastirabilmek mümkünmüdür.
Asrı usta sizin makronuzda bu örnek listeyi size iletmmediğim için adet yazısı olursa hata alıyorum listeyi baz alarak macroyu düzenlemek mümkün müdür.
Genişletmek için tıkla ...
Sayın asri'nin de belirttiği gibi tüm verileriniz belli bir sütuna gelirse o sütuna göre ayrıştırma işlemi yapılır. Bunun için zaten gereken kod desteğiniz mevcut.
 
Ustadlar haklısınız fakat 28 kişiden gelen email türlerine göre düzenledim listeyi.
Aman diyim bu arkadaşların görevi değil bana kod yollamak onun için belirli bir format da gönderin diyemiyorum printscren de var onları ayri tutuyorum aslında karistirmayi ben yaptım 20 varyasyon dan 15 ınden kurtulsam kar kardır olabilme imkanı mevcutmudur acaba.��
 
Son düzenleme:
mustilem23' Alıntı:
Ustadlar haklısınız fakat 28 kişiden gelen email türlerine göre düzenledim listeyi.
Aman diyim bu arkadaşların görevi değil bana kod yollamak onun için belirli bir format da gönderin diyemiyorum printscren de var onları ayri tutuyorum aslında karistirmayi ben yaptım 20 varyasyon dan 15 ınden kurtulsam kar kardır olabilme imkanı mevcutmudur acaba.��
Genişletmek için tıkla ...

Mesajımdaki kod ve dosyalar güncellendi.
Satırdaki bilgi ne kadar karışık olursa olsun, yeterki 10 karakter ve üstü bitişik sayı, 9 karakter ve altı bitişik sayı içinde olsun.
eğer üçüncü bir sayı var ise sorun çıkacaktır.
Formata uygun,
3AD 3507005013
ad zımba 4 3507005014

Formata uygun değil, sonda 3. bir sayı var 34
3AD 3507005013 34

Formata uygun değil, zimba da bitişik 3. bir sayı var 32
ad zımba32 4 3507005014


Size düşen kısmı, tüm verilerinizi kod, açıklama ve birim olarak ayrı bir sayfada tutmak.

Bu çıkan sonuçlardaki kodlara düşeyara ile açıklama ve birimleri getirmek.

Bu verileri
1ad3507005011
2 ad 3507005012
3AD 3507005013
ad zımba 4 3507005014
ZIMBA 3507005015 5
6 ADET 3507005016
3507005017 ZIMBA ADET 7
AD8 3507005018
ad 3507005019 9
adet 3507005020 10
ADET 3507005021 11
3507005022 ZIMBA ADET 12
ZIMBA 3507005023 13
14 3507005024 ADET
AD 3507005025 14
ad zımba 15 3507005026
3507005027 16
17 3507005028
3507005029 ZIMBA ADET 18
3507005030 ZIMBA ADET 19


Bu şekilde listeleyecektir
Kod Adet
3507005011 1
3507005012 2
3507005013 3
3507005014 4
3507005015 5
3507005016 6
3507005017 7
3507005018 8
3507005019 9
3507005020 10
3507005021 11
3507005022 12
3507005023 13
3507005024 14
3507005025 14
3507005026 15
3507005027 16
3507005028 17
3507005029 18
3507005030 19
 
Son düzenleme:
Üstad lar öncelikle bayramınızı en içten dileklerimle kutlarım. Evdeki pc bozuk şirkette ilk iş hemen deneyeceğim çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst