Ağdaki excel belgesinden bilgi alma

[sensiz]

Merhaba arkadaşlar datacenter olarak kullanıdığımız cihazımızda kayıtlı olan bir excel belgesinden belirli verileri almam gerekiyor. Excel belgesi kapalı konumda ben belirlemiş olduğum kriterlerdeki bilgileri masaüstümdeki excel belgesine almak istiyorum. Bu mümkün mü acaba? Eğer böyle birşey olmaz ise belgenin bulunduğu yeri dosya aç menüsü gibi bir işlem ile seçip seçilmiş olan excel belgesinden belirlenen kriterdeki verileri almam mümkünmüdür.örnek belge ektedir.

İstenen kriter şekli şu şekildedir.
Tarih Adı Soyadı Firma Adı Toplam Satılan M2


bu şekilde almam mümkünmü

 

[halit3]

Merhaba arkadaşlar datacenter olarak kullanıdığımız cihazımızda kayıtlı olan bir excel belgesinden belirli verileri almam gerekiyor. Excel belgesi kapalı konumda ben belirlemiş olduğum kriterlerdeki bilgileri masaüstümdeki excel belgesine almak istiyorum. Bu mümkün mü acaba? Eğer böyle birşey olmaz ise belgenin bulunduğu yeri dosya aç menüsü gibi bir işlem ile seçip seçilmiş olan excel belgesinden belirlenen kriterdeki verileri almam mümkünmüdür.örnek belge ektedir.

İstenen kriter şekli şu şekildedir.
Tarih Adı Soyadı Firma Adı Toplam Satılan M2


bu şekilde almam mümkünmü

ağın adresini kendin yazman gerekiyor yada kalasörünü kendin bulman gerekiyor

Dim sat As String
Dim baslangıc As String
Dim bitis As String
Sub Kapalı_dosyadan_veri_al()
baslangıc = Application.InputBox("Başlangıç satırı yazınız.", "Başlangıç satır no", "1", 400, 30, , Type:=1)

If baslangıc = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
bitis = Application.InputBox("Bitiş satırı yazınız.", "Bitiş satır no", "10", 400, 30, , Type:=1)

If bitis = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
If baslangıc <= 0 Then
MsgBox " baslangıc satırı sıfırdan büyük sayı giriniz"
Exit Sub
End If
If baslangıc > 500 Then
MsgBox "baslangıc satır 500 den küçük sayı giriniz."
Exit Sub
End If
If bitis <= 0 Then
MsgBox "bitis satır sıfırdan büyük sayı giriniz"
Exit Sub
End If
If bitis > 500 Then
MsgBox "bitis satır 500 den küçük sayı giriniz."
Exit Sub
End If
If baslangıc > bitis Then
MsgBox "baslangıc satır bitis satır dan büyük olamaz"
Exit Sub
End If
sat = 2 '[a65000].End(3).Row + 1
'Dim sat As Long
A = MsgBox("Sayfayı temizlemek istiyormusunuz ", vbYesNo + vbInformation, C & " Rapor aktarımı")
If A = vbYes Then
ThisWorkbook.Sheets(ActiveSheet.Name).Columns("A:FT").ClearContents
ThisWorkbook.Sheets(ActiveSheet.Name).Columns("A:A").Hyperlinks.Delete
ThisWorkbook.Sheets(ActiveSheet.Name).Columns("A:A").Font.Underline = xlUnderlineStyleNone
Rows("2:" & Rows.Count).Interior.ColorIndex = xlNone
End If
If A = vbNo Then
On Error Resume Next
sat = Cells.Find(What:="*", After:=[A1], LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
End If
If sat <= 1 Then
sat = 2
End If
Dim Kaynak$, Dosyalar$
On Error Resume Next
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 ' ağınızın adresi burada olması gerekiyor
If Kaynak = "" Then
MsgBox "Kaynak klasörü seçmediniz"
Exit Sub
End If
Dosyalar = "*.**"
If Dosyalar = "" Then
MsgBox "Uzantı seçmediniz.?"
Exit Sub
End If
Klasorler Kaynak, "*.*" & Dosyalar
Cells.Select
Selection.VerticalAlignment = xlBottom
Selection.WrapText = False
Selection.Orientation = 0
Selection.AddIndent = False
Selection.ShrinkToFit = False
Selection.ReadingOrder = xlContext
Selection.MergeCells = False
MsgBox "işlem tamam"
End Sub
Sub Klasorler(Kaynak, Dosyalar)
j = [a65000].End(3).Row + 1
Dim dosya_adı, Wdhlg, Yol As String
On Error Resume Next
If Right(Kaynak, 1) <> "\" Then
Kaynak = Kaynak & "\"
Klasor_adı = Kaynak
yer = Kaynak
Else
yer = Kaynak
Klasor_adı = Kaynak
End If
dosya_adı = Dir(Kaynak & Dosyalar)
Do While Len(dosya_adı)
Yol = "'" & Kaynak & "[" & dosya_adı & "]" & x & "'!R"
Application.StatusBar = Yol
Cells(sat, 1).Value = Kaynak & dosya_adı
Cells(sat, 1).Interior.ColorIndex = 8
Cells(sat, 2).Value = Klasor_adı
Cells(sat, 3).Value = dosya_adı
'Cells(sat, 8).Value = Yol
deg = Yol
On Error Resume Next
Cells(sat, 4).Value = "=" & deg & 1 & "C" & 1
'MsgBox deg & 1 & "C" & 1
Cells(sat, 4).Replace What:="=", Replacement:=""
alan1 = Worksheets(ActiveSheet.Name).Cells(sat, 4).Value
For k = 1 To Len(alan1)
If Mid(alan1, k, 1) = "]" Then
yer = (Len(alan1) - 6 - k)
zaman = Mid(alan1, k + 1, yer)
End If
Next
If zaman = "" Then
Cells(sat, 4).Value = Mid(dosya_adı, 1, Len(dosya_adı) - 4)
End If
Cells(sat, 4).Value = zaman
SayfaAdi = zaman
If SayfaAdi = "" Then
SayfaAdi = 1
Else
SayfaAdi = SayfaAdi
End If
On Error Resume Next
deg = "'" & Cells(sat, 2).Value & "\" & "[" & dosya_adı & "]" & SayfaAdi & "'!R"
sat = sat + 1
For s = baslangıc To bitis
Cells(sat, 1) = ExecuteExcel4Macro(deg & s & "C" & 1)
Cells(sat, 2) = ExecuteExcel4Macro(deg & s & "C" & 3)
Cells(sat, 3) = ExecuteExcel4Macro(deg & s & "C" & 4)
son1 = 0
For j = 5 To 14
son1 = son1 + ExecuteExcel4Macro(deg & s & "C" & j)
Next j
Cells(sat, 4) = son1
sat = sat + 1
Next s
sat = sat + 1
'Cells(j, 2).Value = Yol
dosya_adı = Dir()
Loop
dosya_adı = Dir(Kaynak, vbDirectory)
Do While Len(dosya_adı)
If (dosya_adı <> ".") And (dosya_adı <> "..") Then
If (GetAttr(Kaynak & dosya_adı) And vbDirectory) = vbDirectory Then
Klasorler Kaynak & dosya_adı, Dosyalar
Wdhlg = Dir(Kaynak, vbDirectory)
Do While Wdhlg <> dosya_adı
Wdhlg = Dir()
Loop
End If
End If
dosya_adı = Dir()
Loop
On Error GoTo 0
End Sub

 

[sensiz]

Tam istediğim bu değil ekte bir belge gönderdim.Burdaki gibi satış yapan personel ve tarihi firma adı ve firmaya yapmış olduğu toplam satış m2 olacak.Yani E ile N sutunlarını toplayacak. Bunların karşılığını o firmaya ait toplam değeri karşısına yazacak örnek şekilde olduğu gibi olacak

Tarih Siparişi Alan Firma Adı Toplam m2
01.08.2010 ÖZGÜR ÇAM A FİRMASI 2490 M2
04.08.2010 ÖZGÜR ÇAM B FİRMASI 3000 M2

İkinci bir çalışma kitabında

Tarih Siparişi Alan Firma Adı Toplam m2
01.08.2010 RECEP KAYGAN A FİRMASI 2490 M2
04.08.2010 RECEP KAYGAN B FİRMASI 3000 M2

gibi olmasını istiyorum. Ama nasıl yapacağımı bilmiyorum.

 

[sensiz]

şimdiden değerli bilgilerinizden dolayı teşekkür ederim.

 

[halit3]

2 nolu mesajdaki kodu yeniden derledim.