Kapalı dosya içinde metne çevir ve aktar

vivident · 20 Kasım 2017

Merhaba

"MG" isimli dosyanın "HAT PERFORMANSI" isimli sayfasının ;
"D7:H106" ve "N7:N106" hücrelerindeki verilerini

"AA" isimli dosyanın "E" isimli sayfasına almak istiyorum

Problemim şu ;
Veriler karmaşık, yani aynı sütunda sayı ve metin biçimli veriler var. Verileri aktarınca sayı biçimli veriler gelmiyor. Benim düşüncem "MG" isimli kapalı dosyada once veriler metne dönüştürülecek, sonar "AA" isimli dosyaya aktarılacak. Daha sonra ben verilerin formatlarını yine değiştireceğim.

Metne dönüştür kodunu Aktar kodunun içinde nasıl kullanabilirim. Dosyalarım ektedir

Kod:

Sub Aktar()
Application.ScreenUpdating = False
dosya = Application.GetOpenFilename
If dosya = False Then Exit Sub
Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.RECORDSET")
conn.Open "Provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=""excel 12.0;hdr=no;imex=1"";"

rs.Open "select * from [HAT PERFORMANSI$D7:H106];", conn, 1, 1
Sheets("E").Range("B3").CopyFromRecordset rs
rs.Close


rs.Open "select * from [HAT PERFORMANSI$N7:N106];", conn, 1, 1
Sheets("E").Range("G3").CopyFromRecordset rs
rs.Close

conn.Close
Set rs = Nothing
Set conn = Nothing
Application.ScreenUpdating = True
End Sub

Kod:

Sub Metnecevir()
Sheets("HAT PERFORMANSI").Range("D7:N106").NumberFormat = "@"
End Sub

Haluk · 20 Kasım 2017

Gelmeyen veriler hangileri ? Ben anlayamadım ....

Örnek verir misiniz?

.

Edit: Hmmmm.... anladım galiba.

.

vivident · 20 Kasım 2017

E sütunu komple : rakam içeriyor
F sütunu komple : rakam içeriyor
G sütunu komple : rakam içeriyor
B25 hücresi : rakam içeriyor

Bu verileri "AA" isimli dosyaya aktaramıyorum

Haluk · 20 Kasım 2017

Bunu bir deneyin, sonra bakalım duruma ....

Kod:

Sub Aktar()
    dosya = Application.GetOpenFilename
    If dosya = False Then Exit Sub
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.RECORDSET")
    
    conn.Open "Provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=""excel 12.0;hdr=no;imex=1"";"
    
    rs.Open "select * from [HAT PERFORMANSI$D7:N106];", conn, 1, 1
    Sheets("E").Range("B3").CopyFromRecordset rs
    
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
End Sub

.

vivident · 20 Kasım 2017

Sayın Haluk bey malesef olmadı
"D7:N106" aralığındaki tüm metin biçimli veriler aktarldı. Sayı verileri yine bomboş

Haluk · 20 Kasım 2017

Bir de öbür dosya da açıkken deneyin ...

.

halit3 · 20 Kasım 2017

Veri almak istenen dosyada birleştirilmiş hücreler var ayrıca veri alınmak istenen hücrelerde de formüller var ben yeni bir sayfa ekledim veri alınacak dosyaya istenen alanı kopyaladım ve özel yapıştır dan değerleri seçtim ve sayfa adını da deneme yazdım kayıt yaptıktan sonra dosyayı kapattım ilgili koddaki sayfa adını da deneme yaptım ve verileri aldı.

Haluk · 20 Kasım 2017

@vivident:

Yapmanız gereken basitçe;

1) "MG.xlsm" dosyanızın "HAT PERFORMANSI" isimli sayfasındaki tüm verileri seçin "GENEL" olarak biçimlendirin, dosyayı kaydedip kapatın.

2) Aşağıda verdiğim kodu çalıştırın.

Kod:

Sub Aktar_HD()
    dosya = Application.GetOpenFilename
    If dosya = False Then Exit Sub
    
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.RECORDSET")
    conn.Open "Provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=""excel 12.0;hdr=no;imex=1"";"
    
    rs.Open "select * from [HAT PERFORMANSI$D7:H106];", conn, 1, 1
    Sheets("E").Range("B3").CopyFromRecordset rs
    rs.Close
    
    rs.Open "select * from [HAT PERFORMANSI$N7:Q106];", conn, 1, 1
    Sheets("E").Range("G3").CopyFromRecordset rs
    rs.Close
    
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
End Sub

.

vivident · 20 Kasım 2017

sayın haluk bey ve sayın halit3

"MG" isimli dosyanın içinde değişiklik yapamam. Normalde bu dosya ortak alanda, salt okunur bir dosya, ve benim müdahale etmem olanaksız. "HAT PERFORMANSI" sayfasındaki verilerin format biçimlerini "genel" yada "metin" yapınca veriler çekiliyor. Bunu bildiğim için 1. mesajımda kapalı bir dosyada verileri nasıl metine dönüştürebiliriz diye sormuştum. Dönüştürebilirsek verileri kolaylıkla çekebiliriz

Sayın Haluk bey
6. mesajınızda ki "dosya açıkken deneyin" demişsiniz, denedim, tüm verileri eksiksiz çekiyor. Lakin benim için dosya kapalı olmalı

halit3 · 21 Kasım 2017

Farklı bir uygulama ile yazılmış kod
Bu kodu ekleyeceğiniz dosya ile veri alınacak dosya aynı klasörde olmalı kodu çalıştırdığınızda veri alınacak dosyayı seçiniz sonrada veri alınacak sayfayı seçiniz.

Kod:

Sub kapalıverial()

Set Sh = Sheets(ActiveSheet.Name)

kap_dos_sütün_no = "b" 'veri alınacak kapalı dosyanın son dolu satırıma ait sutun adı
sonsat = 65000 'Rows.Count - 1
kap_dos_satir_no = 7 'veri alınacak kapalı dosyanın son dolu sütununa ait satır numarası

ekle1 = Cells(1, 3).Value
ekle2 = Cells(1, 4).Value
ekle3 = Cells(1, 5).Value

Dim fd As FileDialog
Dim selectedPaths() As String
Dim i As Integer

Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
.AllowMultiSelect = True
.FilterIndex = 2
.Title = "Select Excel File(s)"
.InitialFileName = ThisWorkbook.Path
If .Show = -1 Then
ReDim selectedPaths(.SelectedItems.Count - 1)
For i = 0 To .SelectedItems.Count - 1
selectedPaths(i) = .SelectedItems(i + 1)

Kaynak = fd.SelectedItems(i + 1)


If Kaynak = ThisWorkbook.FullName Then GoTo atla

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Klasor = fL.GetParentFolderName(Kaynak)
dosya = fL.GetFileName(Kaynak)

If Right(Klasor, 1) <> "\" Then Klasor = Klasor & "\"

deg = "'" & Klasor & "[" & dosya & "]" & x & "'!R"

Cells(1, 3).Value = "=" & deg & 1 & "C" & 1
Cells(1, 3).Replace What:="=", Replacement:=""
alan1 = Cells(1, 3).Value
alan2 = Right(alan1, InStr(1, StrReverse(alan1), "]", vbTextCompare))
alan3 = Right(alan2, InStr(1, StrReverse(alan2), "!", vbTextCompare))
SayfaAdi = Mid(alan2, 2, Len(alan2) - Len(alan3) - 2)
Cells(1, 3).Value = SayfaAdi


Range("b3:Z" & Columns.Count).ClearContents

deg2 = Klasor & "[" & dosya & "]" & SayfaAdi
deg3 = "'" & Klasor & "[" & dosya & "]" & SayfaAdi & "'!R"

yer1 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "<>""""),COLUMN('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "))"


Cells(1, 4).Value = "=IF(ISERROR(" & yer1 & "),""""," & yer1 & ")"
Cells(1, 4).Value = Cells(1, 4).Value
sut1 = Cells(1, 4).Value ' Kapalı dosyaya ait son dolu sütun sayısı

yer2 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_sütün_no & "1:" & kap_dos_sütün_no & sonsat & "<>""""),ROW('" & deg2 & "'!" & kap_dos_sütün_no & ":" & kap_dos_sütün_no & "))"
Cells(1, 5).Value = "=IF(ISERROR(" & yer2 & "),""""," & yer2 & ")"
Cells(1, 5).Value = Cells(1, 5).Value
sat1 = Cells(1, 5).Value ' Kapalı dosyaya ait son dolu satır sayısı

If Val(sut1) = 0 Or Val(sat1) = 0 Then MsgBox "son dolu satır ve son dolu sütunda değer yok": Exit Sub

Cells(1, 3).Value = ekle1
Cells(1, 4).Value = ekle2
Cells(1, 5).Value = ekle3

sat = 3

For r = 7 To sat1
For s = 4 To 8
Cells(sat, s - 2).Value = ExecuteExcel4Macro(deg3 & r & "C" & s)

On Error Resume Next

If ExecuteExcel4Macro(deg3 & r & "C" & s) = 0 Then
Cells(sat, s - 2).Value = ""
End If

Next s
sat = sat + 1
Next r
atla:

Next i
End If

End With
Set fd = Nothing

Range("a1").Select
MsgBox "işlem tamam"


End Sub

vivident · 21 Kasım 2017

halit bey kod çalışıyor, teşekkür ediyorum, kodlar bana çok karmaşık geldi, ana dosyama uygulamaya çalışacağım, bakalım başarılı olabilecekmiyim, yendien teşekkür ederim

Haluk · 22 Kasım 2017

Merhaba;

Sizin dosyanız için hazırlanmış olan aşağıdaki kod biraz daha basit olup, yaptığım denemelerde olumlu sonuç aldım.
Çok da hızlı çalışmaktadır.

Kod:

Sub Verileri_AL()
    'Haluk - 22/11/2017
    Range("B3:J102").ClearContents
    Dosya = Application.GetOpenFilename
    If Dosya = False Then Exit Sub
    
    mySheet = "HAT PERFORMANSI"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myFile = FSO.GetFile(Dosya)
    filePath = FSO.GetParentFolderName(Dosya)
    
    myStr = "='" & filePath & Application.PathSeparator
    myStr = myStr & "[" & myFile.Name & "]" & mySheet & "'"

    Range("B3:F102").FormulaArray = myStr & "!D7:H106"
    Range("G3:J102").FormulaArray = myStr & "!N7:Q106"
    
    Range("B3:J102").Copy
    Range("B3:J102").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Range("M1").Select
End Sub

.

vivident · 22 Kasım 2017

Haluk bey muazzam çalışıyor. Gerçekten çok hızlı, çok teşekkür ederim

vivident · 22 Kasım 2017

Haluk bey birşey daha rica edebilirmiyim
Kapalı dosyanın içinde 1-2-3-4-5-6...vb giden numeric sayfalar var. Bu sayfadaki veriler alttoplam formülü ile "HAT PERFORMANSI" sayfasına ilgili satırlara (N7:Q106) geliyor. Sizin yaptığınız kodda bu verileri çekiyor

Ben sizin kodda bir değişiklik yapmaya çalıştım, ama yeterli olmadı gibi, Numerik sayfalardaki filitreleri kaldırıp, formülleri otomatik konuma alarak, hesaplama yaptırmak, daha sonra verilerin aktarılmasını sağlamak. Zamanınız varsa bi bakabilirmisiniz

Kod:

Sub Verileri_AL()
    'Haluk - 22/11/2017
    Range("B3:J102").ClearContents
    Dosya = Application.GetOpenFilename
    If Dosya = False Then Exit Sub
    
    mySheet = "HAT PERFORMANSI"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myFile = FSO.GetFile(Dosya)
    filePath = FSO.GetParentFolderName(Dosya)
    
    myStr = "='" & filePath & Application.PathSeparator
    myStr = myStr & "[" & myFile.Name & "]" & mySheet & "'"   
    
[COLOR="Red"]'------------- 'Yeni Eklediğim
    For Each i In Worksheets
    If IsNumeric(i.Name) Then
    Set s2 = i
    s2.Select
    Selection.AutoFilter Field:=1
    Selection.AutoFilter Field:=2
    Selection.AutoFilter Field:=3
    Selection.AutoFilter Field:=4
    End If
    Next i
    Application.Calculation = xlCalculationAutomatic
'-------------[/COLOR]
    
    Range("B3:F102").FormulaArray = myStr & "!D7:H106"
    Range("G3:J102").FormulaArray = myStr & "!N7:Q106"
    
    Range("B3:J102").Copy
    Range("B3:J102").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Range("M1").Select
End Sub

Haluk · 22 Kasım 2017

Merhaba;

Kodun işinize yaradığına sevindim.

Diğer sorunuzla ilgili olarak; daha önce belirttiğiniz gibi, söz konusu dosyanın açılmadan yani kapalı iken işlem yapılmasını istiyorsunuz. Kapalı durumdaki dosyaya müdahale edip, filtreyi kaldırmak ise mümkün değil gibi. Belki; daha önceki kod gibi söz konusu sayfaları kodun olduğu kitaba aktarıp, orada dilediğiniz işlemi ister manuel, ister VBA ile yapabilirsiniz diye düşünüyorum.

Kolay gelsin,

.

vivident · 22 Kasım 2017

Peki haluk bey, filitre iptali için yazılan kod, kapalı dosyada bir modül içinde olsa, ben kapalı dosyadaki o kodu bir şekilde tetikletsem, bu şekilde olur mu ?

Haluk · 22 Kasım 2017

Dosyadaki filtreler bir şekilde kalkarsa, bir şeyler yapılabilir ama .... durumu net olarak bilmediğim ve deneme şansım olmadığı için kesin bir şey söyleyemiyorum.

Örneğin; eğer dosya paylaşıma açılmış bir dosya ise ("share edilmiş"); Microsoft'un güvenlik ayarları nedeniyle zaten kod muhtemelen çalışmayacaktır.

Kolay gelsin,

.

Korhan Ayhan · 22 Kasım 2017

Kapalı dosyadaki makroyu çalıştırdığınızda dosya açılacaktır.

Haluk · 23 Kasım 2017

Belki aşağıdaki kodla çözüme ulaşabilirsiniz.

Bu kodun yaptığı iş; sizin verileri almak istediğiniz dosyayı açmadan, sizin bilgisayarınızdaki My Documents (Belgelerim) klasörüne geçici olarak kopyalar, arka planda açıp sayfalardaki filtreleri kaldırır, kaydedip kapatır. Daha sonra bu dosyadan verileri alıp, sizin sayfanıza aktarır. İşlem bitince, geçici dosya bulunduğu yerden silinir.

Böylelikle, ana dosyanız hiç açılmadan işlemler gerçekleşmiş olur.

Denedikten sonra sonucu bildirirsiniz.

Kod:

Sub Verileri_AL_Filtereler_OFF()
    'Haluk - 23/11/2017
    
    Range("B3:J102").ClearContents
    dosya = Application.GetOpenFilename
    If dosya = False Then Exit Sub
    
    Set WshShell = CreateObject("WScript.Shell")
    strDocuments = WshShell.SpecialFolders("MyDocuments")
    tempFile = strDocuments & Application.PathSeparator & "Temp.xlsm"
    If Dir(tempFile) <> "" Then Kill tempFile
    FileCopy dosya, tempFile
    
    Application.ScreenUpdating = False
    Workbooks.Open tempFile
    For Each Sheet In ActiveWorkbook.Sheets
        If IsNumeric(Sheet.Name) Then
        Sheets(Sheet.Name).AutoFilterMode = False
        End If
    Next
    Workbooks("Temp.xlsm").Close SaveChanges:=True
    Application.ScreenUpdating = True
    
    mySheet = "HAT PERFORMANSI"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myFile = FSO.GetFile(tempFile)
    filePath = FSO.GetParentFolderName(tempFile)
    
    myStr = "='" & filePath & Application.PathSeparator
    myStr = myStr & "[" & myFile.Name & "]" & mySheet & "'"

    Range("B3:F102").FormulaArray = myStr & "!D7:H106"
    Range("G3:J102").FormulaArray = myStr & "!N7:Q106"
    
    Range("B3:J102").Copy
    Range("B3:J102").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Range("M1").Select
    
    Kill tempFile
End Sub

.

vivident · 23 Kasım 2017

Haluk bey çok teşekkür ederim, değişik bir yöntem, oldukça işimi görecek.
Denedim, çalışıyor, elinize sağlık

Kapalı dosya içinde metne çevir ve aktar

vivident

Ekli dosyalar

Haluk

Özel Üye

vivident

Haluk

Özel Üye

vivident

Haluk

Özel Üye

halit3

Uzman

Haluk

Özel Üye

vivident

halit3

Uzman

vivident

Haluk

Özel Üye

vivident

vivident

Haluk

Özel Üye

vivident

Haluk

Özel Üye

Korhan Ayhan

Administrator

Haluk

Özel Üye

vivident