Forum Coders' city Strona Główna Coders' city
Nasza pasja to programowanie!
 

 PomocPomoc   SzukajSzukaj   UżytkownicyUżytkownicy   GrupyGrupy  RejestracjaRejestracja 
Archiwum starego forum + teoria    RSS & Panel/SideBar
 ProfilProfil   Zaloguj się, by sprawdzić wiadomościZaloguj się, by sprawdzić wiadomości   ZalogujZaloguj 

Potrzebuję szybkiej odpowiedzi na moje pytanie... Zasady

Excel - dane z kilku arkuszy



 
Odpowiedz do tematu    Forum Coders' city Strona Główna -> Oprogramowanie biurowe
Zobacz poprzedni temat :: Zobacz następny temat  
Autor Wiadomość
gtomczyk



Dołączył: 24 Lut 2007
Posty: 3

PostWysłany: Sob Lut 24, 2007 9:29 pm      Temat postu: Excel - dane z kilku arkuszy Odpowiedz z cytatem Pisownia

Siemka,
Jestem tutaj nowy, mam male pytanko.
Problem do rozwiazania:
Mam kilka plikow excela z cennikami z roznych hurtowni
Wszystkie maja wspolna kolumne (kod artykulu) oraz ceny dystrybutorow.
Chcialbym stworzyc nowy skoroszyt i umiescic ceny od roznych dostawcow razem, powiazane wspolna kolumna.
Macie pomysly jak to rozwiazac? Fajnie gdyby pozniej istniala mozliwosc aktualizacji.
Z gory dzieki za podpowiedzi.


Ostatnio zmieniony przez gtomczyk dnia Sob Lut 24, 2007 11:55 pm, w całości zmieniany 1 raz
Powrót do góry
Zobacz profil autora Wyślij prywatną wiadomość Numer GG
karolinavb
Site Admin


Dołączył: 25 Maj 2005
Posty: 7277

PostWysłany: Sob Lut 24, 2007 9:40 pm      Temat postu: Odpowiedz z cytatem Pisownia

Cytat:
nowy arkusz w ktorym umiescic bym mogl dane o cenach z roznych arkuszy ?????
różnych arkuszy czy skoroszytów....
I gdzie ten nowy arkusz ...
Przeczytaj swój post jeszcze raz i zweryfikuj wsio.
Powrót do góry
Zobacz profil autora Wyślij prywatną wiadomość
gtomczyk



Dołączył: 24 Lut 2007
Posty: 3

PostWysłany: Sob Lut 24, 2007 11:53 pm      Temat postu: Odpowiedz z cytatem Pisownia

sorry, juz sie poprawiam
dane ktore chcialbym pobrac znajduja sie w roznych skoroszytach (to sa cenniki roznych hurtowni)
natomiast chcialbym stworzyc nowy skoroszyt (wspolny cennik) w ktorym zamiescilbym arkusz z danymi dla wspolnej kolumny kod artykulu w tychze skoroszytach
Powrót do góry
Zobacz profil autora Wyślij prywatną wiadomość Numer GG
karolinavb
Site Admin


Dołączył: 25 Maj 2005
Posty: 7277

PostWysłany: Nie Lut 25, 2007 6:30 pm      Temat postu: Odpowiedz z cytatem Pisownia

Brak info o konstrukcji plików, nazwane zakresy, nagłówki kolumn....
Wobec tego symbolicznie, QueryTables.
Można ADO czy DAO bezpośrednio + poźnie wiązanie+CopyFromRecordset Method,
lecz potrzebuję przynajmniej 1-dnego przykładowego pliku.
As is, dopasuj sobie gdzie trzeba, co trzeba...
Kod:
Option Explicit
Sub test()
    With ThisWorkbook
        '.Worksheets("wyniki").Cells.ClearContents
        Call ListaPlikow(DestRange:=.Worksheets("wyniki").Range("A1"), _
                         vSciezka:=.Path)
    End With
End Sub
'-----------------------------------------

Function DoQueryTab(DestRng As Range, _
                    ByVal SciezkaPlikXls As String) As Long
    On Error GoTo DoQueryTab_Error

    Dim Qr                    As QueryTable
    Dim strSql                As String
    ' załózmy, że sa w arkusdzu o nazwie Arkusz1 w kolumnach A,B
    strSql = "SELECT  *  FROM [Arkusz1$A:B]"
    ' jeżeli zdecydujesz co wybierasz usuń 1-dna z tych opcji
    Set Qr = DestRng.Parent.QueryTables.Add(Connection:= _
                                            VBA.Array( _
                                            "ODBC;DBQ=" & SciezkaPlikXls & ";", _
                                            "DefaultDir=" & SciezkaPliku(SciezkaPlikXls) & ";", _
                                            "Driver={Microsoft Excel Driver (*.xls)};", _
                                            "FIL=Excel 8.0;", _
                                            "MaxBufferSize=2048;", _
                                            "MaxScanRows=8;", _
                                            "PageTimeout=5;", _
                                            "ReadOnly=True;"), _
                                            Destination:=DestRng)
    With Qr
        .CommandType = xlCmdSql
        .CommandText = strSql
        .Name = "dane_1"
        .FieldNames = False: .RowNumbers = False
        .FillAdjacentFormulas = False: .PreserveFormatting = True
        .RefreshOnFileOpen = False: .BackgroundQuery = False
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False: .SaveData = True
        .AdjustColumnWidth = False
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = SciezkaPlikXls
        .Refresh BackgroundQuery:=False
        DoQueryTab = .ResultRange.Rows.Count
    End With
    Set Qr = Nothing
    Call DelQrTab(DestRng.Parent)

DoQueryTab_Exit:
    On Error Resume Next
    Set Qr = Nothing
    Call DelQrTab(DestRng.Parent)
    Exit Function

DoQueryTab_Error:

    MsgBox "Błąd - " & Err.Number & vbCrLf & _
           "Opis -  " & Err.Description & vbCrLf & _
           "Procedura - " & "DoQueryTab", vbExclamation
    Resume DoQueryTab_Exit

End Function
'-----------------------------------------------------
Sub ListaPlikow(DestRange As Range, _
                Optional vSciezka, _
                Optional ByVal JetOledb As Boolean = False)
Dim strSciezka                As String
Dim strPlik                   As String
Dim lngTmpOffset              As Long
Dim lngRes                    As Long
Dim lngPlikNum                As Long
    If Not IsMissing(vSciezka) Then
        strSciezka = vSciezka
    Else
        strSciezka = ThisWorkbook.Path
    End If
    With Application.FileSearch
        .LookIn = strSciezka: .Filename = "*.xls"
        .Execute
        If .FoundFiles.Count = 0 Then
            MsgBox "Nie znaleziono plików."
            Exit Sub
        End If
    End With

    With DestRange
        For lngPlikNum = Application.FileSearch.FoundFiles.Count To 1 Step -1
            strPlik = Application.FileSearch.FoundFiles(lngPlikNum)
            If strPlik <> .Parent.Parent.FullName Then
                lngRes = DoQueryTab(SciezkaPlikXls:=strPlik, _
                                    DestRng:=.Offset(lngTmpOffset, 0))
                lngTmpOffset = lngTmpOffset + lngRes
            End If
        Next lngPlikNum
    End With
End Sub
'-------------------------------------------------------
Sub DelQrTab(Wsh As Worksheet)
Dim strRangeName              As String
Dim qtbQTbl                   As QueryTable
    With Wsh
        If .QueryTables.Count <> 0 Then
            For Each qtbQTbl In .QueryTables
                On Error Resume Next
                strRangeName = qtbQTbl.Name
                qtbQTbl.Delete
                .Names(strRangeName).Delete
            Next qtbQTbl
        End If
    End With
    Set qtbQTbl = Nothing
End Sub
oraz niekoniecznie potrzebne...
Kod:
Public Function SciezkaPliku(ByVal sKatalogAndPlik As String) As String
' jesli to 1-den okreslony katalog lub Jet nie trzeba
Dim strRes                    As String
Dim n                         As Long
    strRes = Trim(sKatalogAndPlik)
    For n = Len(strRes) To 0 Step -1
        If Mid$(strRes, n, 1) = "\" Then
            SciezkaPliku = Left$(strRes, n)
            Exit For
        End If
    Next n
End Function
uwaga:
Kod:
'http://support.microsoft.com/default.aspx?scid=kb;EN-US;257819
' ale http://support.microsoft.com/kb/288343
' zatem gdy nie masz nagłówków użyj Jet OLEDB
'    Set Qr = DestRng.Parent.QueryTables.Add(Connection:= _
     '                                            VBA.Array("OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;", _
     '                                                      "Data Source=" & SciezkaPlikXls & ";", _
     '                                                      "Mode=Read;" & _
     '                                                      "Extended Properties=""HDR=No;"";" & _
     '                                                      "Jet OLEDB:Engine Type=35;"), _
     '                                                      Destination:=DestRng)
Powrót do góry
Zobacz profil autora Wyślij prywatną wiadomość
gtomczyk



Dołączył: 24 Lut 2007
Posty: 3

PostWysłany: Nie Lut 25, 2007 7:50 pm      Temat postu: Odpowiedz z cytatem Pisownia

jejciu, bardzo dziekuje za szybka odpowiedz
postaram sie to przeanalizowac, w razie problemow (na pewno wystapia)pozwole sobie na pytania :)
Powrót do góry
Zobacz profil autora Wyślij prywatną wiadomość Numer GG
Wyświetl posty z ostatnich:   
Odpowiedz do tematu    Forum Coders' city Strona Główna -> Oprogramowanie biurowe Wszystkie czasy w strefie CET (Europa)

Strona 1 z 1

 
Skocz do:  
Możesz pisać nowe tematy
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
Możesz dodawać załączniki na tym forum
Możesz pobierać pliki z tego forum




Debug: strone wygenerowano w 0.03042 sekund, zapytan = 12
contact

| Darmowe programy i porady Jelcyna | VB4all | Tansze zakupy w Helionie | MS Office Blog |