sadece sayısal değerleri aktarmak

[numan şamil]

Merhaba arkadaşlar
Ek dosyamda txt(dosyalar) adlı dosyamda aktar butonuna basınca gelen verilerde (ekli dosyada y firmasının verileri gibi) sıralamaları sıtandart fakat veri alınan satırdaki rakam sayıları farklı değişken veriler aktarmak zorundayım aktar sayfasındaki D-E-F-G-H-I sutundaki hücrelere gelen verilerin rakamların sonlarındaki sayısal olmayan harf v.s şeyleri almayacak veya göstermeyecek şekilde nasıl yapabiliriz.
iyi çalışmalar

 

[numan şamil]

Sorumun bir çözümü varmı?

 

[Korhan Ayhan]

Selamlar,

"Aktar" isimli sayfanızın kod bölümünde kodları aşağıdaki şekilde değiştirip denermisiniz.

Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim Hedef As String
Dim sat1 As String
Dim sat As String
 
Private Sub CommandButton1_Click()
    On Error Resume Next
    Range(Cells(1, 1), Cells(Rows.Count, Columns.Count)).Value = ""
    sat1 = 2
    Dim Baslik As String
    Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
    Set Obj = CreateObject("shell.application")
    Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
    Kaynak = Klasor.Items.Item.Path
    If Not Klasor Is Nothing Then
    If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
    On Error Resume Next
    Liste (Kaynak)
    MsgBox "işlem tamam"
    Else
Atla:
    MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
    End If
    Set Obj = Nothing
    Set Klasor = Nothing
    Exit Sub
Hata:     MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub
 
Private Sub Liste(Yol As String)
    Dim fL As Object, f As Object, Dosya As String, j As Long
    Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Yol).SubFolders
    Dosya = Dir(Yol & "\*.**")
    Application.ScreenUpdating = False
    Do While Dosya <> ""
    DoEvents
    
    
    sat = sat1
    
    If Right(Dosya, 4) = ".txt" Or Right(Dosya, 3) = ".tbr" Then
    Cells(sat, 1).Value = Dosya
    
    i = 2
    j = 0
    
    Open (Yol & "/" & Dosya) For Input As #1
    Do While Not EOF(1)
    Line Input #1, a
    
    j = j + 1
    If j = 3 Then
    i = 3
    Cells(sat, i).Value = Mid(a, 9, 8)
    i = i + 1
    ElseIf j = 7 Then
    Cells(sat, i).Value = SAYIAL(Mid(a, 10, 10))
    i = i + 1
    ElseIf j = 9 Then
    Cells(sat, i).Value = SAYIAL(Mid(a, 10, 9))
    i = i + 1
    ElseIf j = 11 Then
    Cells(sat, i).Value = SAYIAL(Mid(a, 10, 9))
    i = i + 1
    ElseIf j = 13 Then
    Cells(sat, i).Value = SAYIAL(Mid(a, 10, 9))
    i = 10
    ElseIf j = 15 Then
    Cells(sat, i).Value = SAYIAL(Mid(a, 10, 5))
    i = 8
    ElseIf j = 17 Then
    Cells(sat, i).Value = SAYIAL(Mid(a, 10, 8))
    i = 9
    ElseIf j = 19 Then
    Cells(sat, i).Value = Mid(a, 10, 8)
    i = i + 1
    End If
    
    Loop
    Close
    
    sat = sat + 1
    Application.DisplayAlerts = True
    
    End If
    sat1 = sat
    Dosya = Dir
    Loop
    
    On Error GoTo sonraki
    For Each f In fL
    Kaynak = f.Path
    Liste (f.Path)
sonraki:
    Next
    
    Set fL = Nothing
End Sub
 
Function SAYIAL(Veri)
    Dim X As Integer
    
    For X = 1 To Len(Veri)
        If IsNumeric(Mid(Veri, X, 1)) Then
            SAYIAL = SAYIAL & Mid(Veri, X, 1)
        End If
    Next
End Function

 

[numan şamil]

Selamlar Korhan hocam ilginize teşekkürler
kodlarınızı uyguladım sorun çözüldü fakat aktarılan verilerdeki Örn:102.911 olan rakamları 102911 şeklinde aktarıyor verileri 102.911 şeklinde aktarabilecek şekilde düzenleyebilirmiyiz
birde ekteki dosyada modüle 1 deki kodlardada değişiklik yapacakmıyım?
iyi çalışmalar

 

[Korhan Ayhan]

Selamlar,

Peki dosyanıza göre "010193.901" şeklinde olan verinizi hücrede nasıl görmek istiyor sunuz?

 

[numan şamil]

selamlar hocam
c hücresindeki gelen veriler hariç (c sutunu metin tanımlı bu sutuna gelecek verilerin rakkamlardan önceki sıfır varsa alması gerekiyor) diğer hücrelere gelen verilerin rakkam önündeki sıfırın önemi yok sadece noktadan sonra üç haneli rakkam varsa bu kısmını olduğu gibi almalı "010193.901" 'i " 10193,901" şeklinde almasında bir sakınca yok

 

[Korhan Ayhan]

Selamlar,

Siz Modül1 deki makronuzu nasıl çalıştırıyor sunuz?

Bu makronuzda kulandığınız "sat" değişkeni bir değer almadığı için süreki hata veriyor.

 

[numan şamil]

Hocam modüle 1 deki kodları sildim denedim verileri aktarıyor "sat=sat1" sat1=2" şeklinde aktar sayfası kodlarında modül 1 deki kodları ekteki dosyada ilgili yerleri sizin gönderdiğiniz kodlarla değiştirdim Ayrıca bende hata vermiyor veya farkında değilim Yanlış bilmiyorsam Modüle 1 deki kodların olup olmaması benim işimi engellemiyor gibi sizin öneriniz nedir kalsınmı siliyimmi ? önemli olan "10193.901" olayı bu veriler üzerinden hesaplamalar yapılıyor. ("10193.901" şeklinde veya "010193.901" her ikisinden hangisi olursa olsun farketmez )

 

[Korhan Ayhan]

Selamlar,

Bu durumda Modül1 deki kodları silin. Ekteki örneği inceleyiniz.

 

[numan şamil]

Merhaba korhan bey
Dosyanızı inceledim.kodlarda (Genaral) bölümüne
Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim Hedef As String
Dim sat1 As String
Dim sat As String kodları ekledim çalışıyor
Korhan hocam ellerine sağlık istediğim gibi oldu elimdeki diğer dosyalarada uygulayacağım bir sorun çıkarsa forma yazarım
bu arada modül 1 kendisini nasıl siliyoruz?
iyi çalışmalar

 

[numan şamil]

Merhabalar korhan bey
Göndermiş olduğunuz örnek dosyada " TÜMÜ" butonuna bastığımda tektek masa üstüne doğru şekilde dosyaları atıyor
Yalnız Ekteki farklı dosyada aktar sayfasında"TÜMÜ" butonuna bastığımda oluşturulan klosör içine atılan dosyalarda her ikisininde ilk sıradaki x firmasının değerleri oluyor (dosya isimleri farklı fakat içindeki değerler ilk satırdaki x firmasının değerleri) Galiba sorun modül 5 deki kodlarda
Not: "kopyala yapıştır" "Yeni excel kitabı oluştur" "satır sil" butonları ile tek tek işlem yapınca sorun olmuyor (bu yöntemle oluşturulacak dosya sayısı 70 adet civarında)
Mod5 teki kodlar:
ekteki dosyada düzenliye bilirmisiniz.
Option Explicit
Sub AktifSayfayıÇalışmaKitabıOlarakKaydet()
Dim Dosya_Sistemi As Object, Klasör As String
Dim Kitap_Adı As String, Dosya_Yolu As String, Dosya_Adı As String
Dim X As Long, S1 As Worksheet, S2 As Worksheet

Set S1 = Worksheets("Aktar")
Set S2 = Worksheets("Sayfa1")

If WorksheetFunction.CountA(S1.Range("A:A")) = 0 Then
MsgBox "Aktarım yapılacak veri bulunamadı !", vbExclamation
Exit Sub
End If

Application.ScreenUpdating = False

Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
Dosya_Yolu = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\Oluşturulan Klasör\"

If Not Dosya_Sistemi.FolderExists(Dosya_Yolu) Then
Dosya_Sistemi.CreateFolder (Dosya_Yolu)
End If


For X = 2 To S1.Range("A65536").End(3).Row
S2.Range("AN6") = S1.Range("C2")
S2.Range("R51") = S1.Range("D2")
S2.Range("Z51") = S1.Range("E2")
S2.Range("AL51") = S1.Range("F2")
S2.Range("AU51") = S1.Range("G2")

S2.Range("X36") = S1.Range("H2")

S2.Range("R52") = S1.Range("I2")
S2.Range("Z52") = S1.Range("J2")
S2.Range("AL52") = S1.Range("K2")
S2.Range("AU52") = S1.Range("L2")




Kitap_Adı = S1.Cells(X, 1) & ".xls"
Dosya_Adı = Dosya_Yolu & Kitap_Adı
S2.Copy
ActiveSheet.Name = "Sayfa1"

Dosya_Yolu = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\Oluşturulan Klasör\" & Kitap_Adı

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Dosya_Yolu
ActiveWorkbook.Close False
Application.DisplayAlerts = True
Next

S1.Range("A265536").ClearContents

Set Dosya_Sistemi = Nothing
Set S1 = Nothing
Set S2 = Nothing

Application.ScreenUpdating = True

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

Function SAYIAL(Veri As String)
Dim X As Integer

For X = 1 To Len(Veri)
If IsNumeric(Mid(Veri, X, 1)) Or Mid(Veri, X, 1) = "." Then
SAYIAL = SAYIAL & Mid(Veri, X, 1)
End If
Next
End Function

 

[numan şamil]

Arkadaşlar mesaj 11 deki sorunumu çözecek varmı ?

 

[halit3]

Kodlarında sadece düzüenleme yaptım sorununuz döngüde kodun ilgili bölümlerini aşağıda ile değiştirin.

S2.Range("AN6") = S1.Range("C" & X)
S2.Range("R51") = S1.Range("D" & X)
S2.Range("Z51") = S1.Range("E" & X)
S2.Range("AL51") = S1.Range("F" & X)
S2.Range("AU51") = S1.Range("G" & X)

S2.Range("X36") = S1.Range("H" & X)

S2.Range("R52") = S1.Range("I" & X)
S2.Range("Z52") = S1.Range("J" & X)
S2.Range("AL52") = S1.Range("K" & X)
S2.Range("AU52") = S1.Range("L" & X)

 

[numan şamil]

Çok teşekkür ederim elinize sağlık mükemmel çalışıyor
iyi çalışmalar