Browse seçeneğiyle dosya konumundan veri çekme ve hesaplama

[bluwer]

Tekrar herkese merhaba,

Eminimki forumdaki birçok arkadaş benden çok daha üstün bilgiye sahiptir. Ben sadece benimkine benzer olan olaylardan aldığım kodları kendime uyarlamaya çalışan biriyim. İstediğim çalışmayı yapabildim fakat uzun yoldan yaptığımı zannediyorum. Bana gerekli olan sadece birkaç düzenleme. Lütfen gerekli bilgi ve beceriye sahipseniz yardımcı olun.

eklediğim dosyadanda anlaşılacağı üzere;

öncelikte ekte sunduğum ap.xlsx ve ap+t.xlsx dosyaları tamamen örnek olsun diye konulmuştur.

Yapmak istediğim : Dosya konumunu benim seçtiğim bir excel dosyasından verileri tabloma aktarmak ve daha sonra dosya konumundan seçilin dosyanın kapanmasını sağlamak.

Yaptığım : Dosya konumunu seçip verileri aktarabildim fakat dosyanın kapanmasını sağlayacak komutu bulamadığımdan delete komutunu kullandım, bunda bazı aksilikler var. Açtığım dosya 2 sayfadan oluşuyor ve ben bunun ilk sayfasını çalışma yaptığım excel dosyasına yan sayfa olarak ekliyorum ve verileri tabloma ordan çekiyorum daha sonrasında da o sayfayı siliyorum fakat açılan dosya 2 sayfa olduğu için 2. sayfası ayrı bir excel dosyası olarak açılıyor ve açık kalıyor.

Kodlar :

Private Sub CommandButton1_Click()

    Dim FilesToOpen
    Dim x As Integer
     
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
     
    FilesToOpen = Application.GetOpenFilename _
    (FileFilter:="Microsoft Excel Files (*.xlsx), *.xlsx", _
    MultiSelect:=True, Title:="Files to Merge")
     
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Hiçbir Dosya Seçilmedi"
        GoTo ExitHandler
    End If
     
    x = 1
    While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        Sheets(1).Move After:=ThisWorkbook.Sheets _
        (ThisWorkbook.Sheets.Count)
        x = x + 1
    Wend
ThisWorkbook.Sheets("Spectrum Data").Range("b2:b33").Copy
ThisWorkbook.Sheets("Sayfa1").Range("b3:b34").PasteSpecial
ThisWorkbook.Sheets("Spectrum Data").Delete

ExitHandler:
    Application.ScreenUpdating = False
    Exit Sub
     
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler

End Sub

Diğer sorunum : CommandButton3,4 ve 5 ile yapmaya çalıştığım şey verileri belirli bir aralıkta belirlemiş olduğum standarta göre değerlendirmek. Bu değerlendirme için renklerle belirmiş olduğum aralıkta maksimum değere ulaşan verinin komşularıyla olan farkına bakıyorum.

Hata: Burda karşılaştığım hata eğer maksimum değer renkle gösterdiğim aralığın ilk yada son değeri ise aralığın dışında kalan komşusuna görede hesap yapıyor. Oysaki sadece aralık içindeki komşularıyla olan farkına bakmak istiyorum.

Kod :

Private Sub CommandButton3_Click()

Dim MaxVal As Double
Dim MaxRng As Range
MaxVal = Application.WorksheetFunction.Max(Range("d5:d12"))
Range("G9").Value = MaxVal
Set MaxRng = Range("D5").Offset(Application.WorksheetFunction.Match(MaxVal, Range("d5:d12"), 0) - 1)
Debug.Print MaxVal
Debug.Print MaxRng.Address

For i = 5 To 12
If Range("d" & i).Value = MaxVal Then
Range("d" & i).Select
End If
Next i

Range("G8").Value = ActiveCell.Offset(-1, 0)
Range("H8").Value = MaxVal - ActiveCell.Offset(-1, 0)
Range("G10").Value = ActiveCell.Offset(1, 0)
Range("H10").Value = MaxVal - ActiveCell.Offset(1, 0)

End Sub

Birde komşu değer 0 ise ben farkına bakılmaksızın Uygun olarak yazılmasını istiyorum.

Yardımcı olacak olursa şimdiden Allah razı olsun.

 

[tamer42]

Merhabalar,

Browse ile dosya seçerken, seçtiğimiz bu dosyanın bulunduğu klasör adını kod ile nasıl öğrenebiliriz?

FilesToOpen.Path denedim hata mesajı verdi.

......................
  FilesToOpen = Application.GetOpenFilename _
    (FileFilter:="Microsoft Excel Files (*.xlsx), *.xlsx", _
    MultiSelect:=True, Title:="Files to Merge")
....................

iyi çalışmalar.

 

[Zeki Gürsoy]

Şöyle olabilir:

if isarray(filestoopen)
    msgbox replace(filestoopen(1), dir(filestoopen(1), "")
else
    msgbox replace(filestoopen, dir(filestoopen, "")
end if

 

[tamer42]

Şöyle olabilir:

if isarray(filestoopen)
    msgbox replace(filestoopen(1), dir(filestoopen(1), "")
else
    msgbox replace(filestoopen, dir(filestoopen, "")
end if

Teşekkürler Zeki GÜRSOY,

en sonunda gelen\ işareti olmadan

D:\Users\User\Documents\Veri[B]\[/B]

yerine;

D:\Users\User\Documents\Veri

bu şekilde olması sağlanamaz mı?
iyi çalışmalar.

 

[Zeki Gürsoy]

Öyleyse şunu deneyin. Ancak root dizinlerde "C:", "D:" gibi sonuçlar alırsınız bilginiz olsun.

if isarray(filestoopen)
    msgbox replace(filestoopen(1), "\" & dir(filestoopen(1), "")
else
    msgbox replace(filestoopen, "\" & dir(filestoopen, "")
end if

 

[tamer42]

Teşekkürler Zeki Gürsoy;