Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 70200 Skopiuj do schowka Ustalenie ostatniego wiersza w kolumnie w zamkniętym pliku
Autor Wiadomość
Leon M 
Fan Excela


Wersja: Win Office 2010
Posty: 97
Wysłany: 20-02-2021, 21:00   Ustalenie ostatniego wiersza w kolumnie w zamkniętym pliku

Szanowni Forumowicze, kieruję prośbę do Was o pomoc w następującej kwestii:

W zamkniętym skoroszycie źródłowym jest tabela o zmiennej ilości wierszy. Jak uzyskać numer ostatniego wiersza tej tabeli za pomocą odpowiedniego kodu VBA z poziomu skoroszytu wynikowego?

Zamieszczone w załączniku przykładowe pliki obrazują kwestię.

Z góry pięknie dziękuję za wszystkie odpowiedzi.

Demo11.rar
Pobierz Plik ściągnięto 5 raz(y) 22.06 KB

ID posta: 400765 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 771 razy
Posty: 4155

Wysłany: 20-02-2021, 21:26   

Ustaw odpowiednią ścieżkę.
Kod:
Private Sub CommandButton1_Click()
Dim wb          As Workbook
Dim strPath     As String
Dim d           As Long

Application.ScreenUpdating = False
strPath = "L:\Baza1.xlsx"
Set wb = Workbooks.Open(strPath)
d = wb.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
wb.Close False
Application.ScreenUpdating = True

MsgBox d

End Sub
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
Chcesz precyzyjną odpowiedź - zadaj precyzyjne pytanie.
ID posta: 400766 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2494 razy
Posty: 8280
Wysłany: 20-02-2021, 21:45   

To zamieńmy funkcję
Kod:
Option Explicit

Sub Pobieranie()
Dim vArr() As Variant
Dim p$, f$, s$, r$

    p = "g:\Roboczy 3\"
    f = "Baza1.xlsx"
    s = "Arkusz1"
    r = Columns(1).Address(False, False)
    vArr = ADOGetValue(p, f, s, r)

    Range("E2").Resize(UBound(vArr)).Value = vArr

End Sub

'http://www.excelforum.pl/topics3/funkcja-getvalue-vt12354.htm?postdays=0&postorder=asc&highlight=%2Aadogetvalue%2A&start=0
Function ADOGetValue(path As String, file As String, sheet As String, ref As String)
' =ADOGetValue(p;f;s;r)
' p - scieżka
' f - nazwa pliku
' s - nazwa arkusza
' r - komórka lub obszar np. "A3", "A1:A10"
Dim arg As String
Dim nRowCount As Long, nColCount As Long
Dim nActRow As Long, nActCol As Long
Dim ArrVal() As Variant
Dim xArray As Variant
Dim xValue As Variant
Dim strConnectionString As String
Dim oCn As Object, oRs As Object


    On Error GoTo ADOGetValue_Error

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

    If Dir(path & file) = "" Then
        'brak pliku ...
        ADOGetValue = CVErr(2042)
        Exit Function
    End If

    Set oCn = CreateObject("ADODB.Connection")

    If Val(Application.Version) < 12 Then
        strConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                              "Data Source=" & path & file & ";" & _
                              "Extended Properties=""Excel 8.0;HDR=NO;IMEX=1;"""
    Else
        strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & path & file & ";" & _
                              "Extended Properties=""Excel 12.0;HDR=NO;IMEX=1;"""
    End If
   
    oCn.Open strConnectionString
    arg = "select * from [" & sheet & "$" & ref & _
          IIf(InStr(ref, ":") = 0, ":" & ref, "") & "]"

    Set oRs = CreateObject("ADODB.Recordset")

    oRs.Open arg, oCn, 3

    xArray = oRs.getRows

    nRowCount = UBound(xArray, 2)
    nColCount = UBound(xArray, 1)

    ReDim ArrVal(1 To nRowCount + 1, 1 To nColCount + 1)

    For nActRow = 0 To nRowCount

        For nActCol = 0 To nColCount

            xValue = xArray(nActCol, nActRow)

            If IsNumeric(xValue) Then
                xValue = CDbl(xValue)
            ElseIf IsNull(xValue) Then
                xValue = Empty
            End If

            ArrVal(nActRow + 1, nActCol + 1) = xValue

        Next

    Next

    ADOGetValue = ArrVal

    oRs.Close
    oCn.Close

    Set oRs = Nothing
    Set oCn = Nothing

    On Error GoTo 0
    Exit Function

ADOGetValue_Error:
    ReDim ArrVal(1 To 1, 1 To 1)
    ArrVal(1, 1) = vbNullString
    ADOGetValue = ArrVal
End Function
Co prawda nie jest to pobranie numeru ostatniego wiersza, ale to żaden problem puścić pętlę po vArr i sprawdzić który element w tablicy jest niepusty jako ostatni.
Np. tak:
Kod:
Sub Pobieranie()
Dim vArr() As Variant
Dim p$, f$, s$, r$, i&, Ans&

    p = "g:\Roboczy 3\"
    'p = "C:\Users\mkkk2\Downloads\Demo11\"
    f = "Baza1.xlsx"
    s = "Arkusz1"
    r = Columns(1).Address(False, False)
    vArr = ADOGetValue(p, f, s, r)

    For i = 1 To UBound(vArr)
        If VBA.Len(vArr(i, 1)) > 0 Then Ans = i
    Next i
    MsgBox "Ostatni wierszy w " & f & " to " & Ans

End Sub
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
  
ID posta: 400771 Skopiuj do schowka
 
 
Leon M 
Fan Excela


Wersja: Win Office 2010
Posty: 97
Wysłany: 21-02-2021, 11:21   

Pięknie dziękuję za przedstawione sposoby rozwiązania przedłożonej kwestii.

Mam pytanie odnośnie fragmentu kodu zaprezentowanego przez Mareckiego:

Kod:
 
r = Columns(1).Address(False, False)
vArr = ADOGetValue(p, f, s, r)


Zmienna r otrzymuje wartość A:A, czy to skutkuje tym, że do tablicy vArr zostaje przypisana cała kolumna nr 1?

Za odpowiedzi z góry bardzo dziekuję.
ID posta: 400790 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2494 razy
Posty: 8280
Wysłany: 21-02-2021, 19:42   

Odniesienie jest do całej kolumny, ale jak przejdziesz krokowo przez funkcję to zauważysz że iteracja odbywa się po komórkach kolumny w których jest przechowywana jakaś wartość lub ma jakieś formatowanie
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 400809 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe