txt dosyasından değer çekiyorum çekmiş olduğum değeri her seferde yeni bir sheet olar

[byenerji]

bir tane txt dosyasından değer çekiyorum çekmiş olduğum değeri her seferde yeni bir sheet olarak ekleyebilirmiyim.
çektiğim sayfayı arşivlemek istiyorum.

Dim dosya As String, d As String
Dim arr As Variant, c As Integer, s As Long

Const SUT As Integer = 84

On Error Resume Next

dosya = Application.GetOpenFilename( _
"Text Dosyaları (*.txt) (*.txt), *.txt", 1, _
"test")

If dosya = "False" Then Exit Sub

Range(Cells(1, 1), Cells(65536, SUT)).Columns.NumberFormat = "@"

Open dosya For Input As #1

While Not EOF(1)
s = s + 1

Line Input #1, d

arr = Split(d, vbTab)

For c = 0 To SUT
Cells(s, c + 1) = arr(c)
Next

Wend

Close #1

If Err.Number <> 0 Then MsgBox Err.Description, vbExclamation, _
"test"

 

[Mehmet Şahin]

Merhaba,
aşağıdaki şekilde deneyiniz. İyi çalışmalar.

Dim dosya As String, d As String
Dim arr As Variant, c As Integer, s As Long
Dim sh As Worksheet
Const SUT As Integer = 84

On Error Resume Next

dosya = Application.GetOpenFilename( _
"Text Dosyaları (*.txt) (*.txt), *.txt", 1, _
"test")

If dosya = "False" Then Exit Sub
      Set sh = Sheets.Add: sh.Name = "Sheet" & Sheets(Sheets.Count) + 1
      sh.Move after:=Sheets(Sheets.Count)



sh.Range(sh.Cells(1, 1), sh.Cells(65536, SUT)).Columns.NumberFormat = "@"

    Open dosya For Input As #1
        While Not EOF(1)
        s = s + 1
        Line Input #1, d
        arr = Split(d, vbTab)
            For c = 0 To SUT
                sh.Cells(s, c + 1) = arr(c)
            Next
        Wend
    Close #1
If Err.Number <> 0 Then MsgBox Err.Description, vbExclamation, _
"test"

 

[Korhan Ayhan]

Merhaba,

"If dosya = "False" Then Exit Sub"

Satırından sonra alttaki kodu eklerseniz istediğiniz sonuca ulaşırsınız.

    Sheets.Add Sheets(Worksheets.Count)
    ActiveSheet.Name = Date

Ben yeni eklenen sayfaya isim olarak günün tarihini verdim. Siz kendinize göre değiştiriniz.

 

[byenerji]

Yardımlarınız için çok teşekkürler.

 

[byenerji]

arkadaşlar 2. txt dosyasını aynı sheet içinde c sutununa yapıştırabilirmiyim

arkadaşlar 2. txt dosyasını aynı sheet içinde c sutununa yapıştırabilirmiyim
2tane txt dosyasını yeni oluşturduğum sheet içine kopyalama şansım varmı ve yeni oluşturduğum sheet te bu günün tarihini atabilirmiyim.
yardımlarınız için teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Txt dosyası eklemediğiniz için hangi verileri almak istediğinizi tahmin edemedim. Mesajınızda da belirtmemişsiniz. Dosya seçme ekranında çoklu seçim yapabilirsiniz.

Aşağıdaki kodu deneyin. Olmayan yerlerini düzeltiriz.

Private Sub CommandButton3_Click()
    Dim Dosya, d As String, sayfa As Worksheet
    Dim arr As Variant, s As Long, x As Byte
    Dim sh As Worksheet, isim As String
 
    On Error GoTo Hata
 
    Dosya = Application.GetOpenFilename("Text Dosyaları (*.txt) (*.txt), *.txt", 1, _
    "Lütfen dosya seçiniz...", MultiSelect:=True)
 
    If Not IsArray(Dosya) Then
        MsgBox "Dosya seçimi yapmadığınız için işleminiz iptal edilmiştir !", vbExclamation
        Exit Sub
    End If
 
    isim = Date
    On Error Resume Next
    Set sayfa = Sheets(isim)
    If sayfa Is Nothing Then
    On Error GoTo 0
 
        Set sh = Sheets.Add: sh.Name = Date
        sh.Move after:=Sheets(Sheets.Count)
        sh.Range("C:C").NumberFormat = "@"
 
        For x = LBound(Dosya) To UBound(Dosya)
            Open Dosya(x) For Input As #1
                While Not EOF(1)
                    s = s + 1
                    Line Input #1, d
                    sh.Cells(s, "C") = d
                Wend
            Close #1
        Next
 
    Else
 
        sh.Range("C:C").ClearContents
 
        For x = LBound(Dosya) To UBound(Dosya)
            Open Dosya(x) For Input As #1
                While Not EOF(1)
                    s = s + 1
                    Line Input #1, d
                    sh.Cells(s, "C") = d
                Wend
            Close #1
        Next
    End If
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Exit Sub
 
Hata:
    If Err.Number <> 0 Then MsgBox Err.Description, vbExclamation
End Sub

 

[byenerji]

yardımlarınız için çok teşekkürler