Soru F7 hücresinden başlayıp son dolu hücreye kadar veri aldırmak hk.

[balanar]

Merhaba, gözat butonuna tıklayıp bir excel seçtiğimizde o seçilen excel'in

ABCD adlı sayfasının f7 hücresinden başlayıp aşağıya doğru kaç adet dolu satır varsa o verileri alip

Gözat butonunun oldugu sayfadaki f7den aşağı kopyalayacak bu yapılabilir mi?

 

[balanar]

şöyle kapalı dosyadan veri alma var ama uyduramadım ben

Private Sub CommandButton1_Click()
Dim conn As Object, rs As Object, sonsat As Long
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
sonsat = Cells(Rows.Count, "A").End(xlUp).Row + 1
conn.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook.Path & "\kapalı.xlsm;extended properties=""excel 12.0;hdr=no;imex1"""
rs.Open "select * from [Sayfa1$];", conn, 1, 3
Application.ScreenUpdating = False
If rs.RecordCount > 0 Then Range("A" & sonsat).CopyFromRecordset rs
Application.ScreenUpdating = True
rs.Close
conn.Close
Set rs = Nothing: Set conn = Nothing
End Sub

 

[EmrExcel16]

Merhaba deneyiniz..

Private Sub CommandButton1_Click()
    Dim Dosya, Dsy, Sonsat
    Application.ScreenUpdating = False
    Dosya = Application.GetOpenFilename(Title:="Lutfen dosya secimi yapiniz")
    If Dosya = False Then
        Exit Sub
    Else
        Set Dsy = Workbooks.Open(Filename:=Mid(Dosya, 1, Len(Dosya) - Len(Dir(Dosya))) _
        & Mid(Dosya, InStrRev(Dosya, "\") + 1), UpdateLinks:=3, ReadOnly:=True)
        Sonsat = Workbooks(Dsy.Name).Sheets("ABCD").Cells(Rows.Count, 6).End(xlUp).Row
        ThisWorkbook.ActiveSheet.Range("F7:F10000").ClearContents
        ThisWorkbook.ActiveSheet.Range("F7:F" & Sonsat).Value = _
        Workbooks(Dsy.Name).Worksheets("ABCD").Range("F7:F" & Sonsat).Value
    End If
    Workbooks(Dsy.Name).Close
    Application.ScreenUpdating = True
    MsgBox "islem tamam"
End Sub

 

[balanar]

@EmrExcel16 çok teşekkür ediyorum tam istediğimiz buydu.. Emeğinize sağlık

 

[EmrExcel16]

Rica ederim , iyi çalışmalar.

 

[balanar]

Rica ederim , iyi çalışmalar.

Emre bey şunu aynı mantıkta nasıl yapabiliriz peki?

Yani başka bi butona bu kodu koyacam ama önce gözat mantıgında bi dosya seçtirip o seçilen dosya üzerinde bu işlemi yapmasını nasıl saglayabilirim

Bu diğer koddan bağımsız ayrı bir butonda yapacagım

Private Sub CommandButton1_Click()
Dim son As Long, i As Long

    Range("S7:U" & Rows.Count).ClearContents
    Range("S7:U" & Rows.Count).Interior.ColorIndex = xlNone

    son = Cells(Rows.Count, "B").End(xlUp).Row

  [S7].Resize(son - 6, 1).Formula = "=(E7*F7)"
    [T7].Resize(son - 6, 1).Formula = "=(E7*G7)"
    [U7].Resize(son - 6, 1).Formula = "=(E7*H7)"

    Range("S" & son + 2) = WorksheetFunction.Sum(Range("S7:S" & son))
    Range("T" & son + 2) = WorksheetFunction.Sum(Range("T7:T" & son))
    Range("U" & son + 2) = WorksheetFunction.Sum(Range("U7:U" & son))
   
    For i = 7 To son
        If Cells(i, "I") <> Cells(i, "S") Then Cells(i, "S").Interior.ColorIndex = 3
        If Cells(i, "J") <> Cells(i, "T") Then Cells(i, "T").Interior.ColorIndex = 3
        If Cells(i, "K") <> Cells(i, "U") Then Cells(i, "U").Interior.ColorIndex = 3
    Next i
End Sub

 

[EmrExcel16]

Verdiğim kodlar içinde "Else" - "End if" arasını silip kendi kodlarınızı ekleyerek deneyin.

 

[balanar]

öyle yapınca butonun oldugu sayfaya çekiyor hocam. Ben istiyorumki gözat yoluyla çekilen sayfada işlem yapsın

 

[EmrExcel16]

Bu şekilde deneyin

Private Sub CommandButton1_Click()
    Dim Dosya, Dsy
    Application.ScreenUpdating = False
    Dosya = Application.GetOpenFilename(Title:="Lutfen dosya secimi yapiniz")
    If Dosya = False Then
        Exit Sub
    Else
        Set Dsy = Workbooks.Open(Filename:=Mid(Dosya, 1, Len(Dosya) - Len(Dir(Dosya))) _
        & Mid(Dosya, InStrRev(Dosya, "\") + 1), UpdateLinks:=3)
    

    
        Dim son As Long, i As Long
    
        ActiveSheet.Range("S7:U" & Rows.Count).ClearContents
        ActiveSheet.Range("S7:U" & Rows.Count).Interior.ColorIndex = xlNone
    
        son = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
    
        ActiveSheet.[S7].Resize(son - 6, 1).Formula = "=(E7*F7)"
        ActiveSheet.[T7].Resize(son - 6, 1).Formula = "=(E7*G7)"
        ActiveSheet.[U7].Resize(son - 6, 1).Formula = "=(E7*H7)"
    
        ActiveSheet.Range("S" & son + 2) = WorksheetFunction.Sum(ActiveSheet.Range("S7:S" & son))
        ActiveSheet.Range("T" & son + 2) = WorksheetFunction.Sum(ActiveSheet.Range("T7:T" & son))
        ActiveSheet.Range("U" & son + 2) = WorksheetFunction.Sum(ActiveSheet.Range("U7:U" & son))
      
        For i = 7 To son
            If ActiveSheet.Cells(i, "I") <> ActiveSheet.Cells(i, "S") Then ActiveSheet.Cells(i, "S").Interior.ColorIndex = 3
            If ActiveSheet.Cells(i, "J") <> ActiveSheet.Cells(i, "T") Then ActiveSheet.Cells(i, "T").Interior.ColorIndex = 3
            If ActiveSheet.Cells(i, "K") <> ActiveSheet.Cells(i, "U") Then ActiveSheet.Cells(i, "U").Interior.ColorIndex = 3
        Next i
    

    
    End If
    'Workbooks(Dsy.Name).Close
    Application.ScreenUpdating = True
    MsgBox "islem tamam"
End Sub

 

[balanar]

Çok teşekkür ediyorum elinize sağlık hocam