napisał: VBAmator
postów: 67
 umieszczony:
22 marca 2018
15:21
|
|
Kod zaadaptowany, działa szybko. Bardzo dziękuję za pomoc.
Hahaha, skąd pomysł na nazwę pliku w przykładzie? Skądinąd bardzo trafiony... |
|
|
napisał: Trebor
postów: 1209
umieszczony:
21 marca 2018
21:00
 edytowany:
21 marca 2018
21:19
|
|
Z tego co czytam w Internecie to jest to duży problem. Podają jakieś tam rozwiązania ale dość skomplikowane. Sprawdź ile będzie się u Ciebie wykonywać kopia skoroszytu i jej usunięcie. Coś w rodzaju:
Sub kopia()
FileCopy "C:\......\motyle.xlsx", "C:\........\motyle2.xlsx"
Kill "C:\........\motyle2.xlsx"
End Sub
O ile pamiętam to kopię pliku musisz robić w obrębie jednego dysku.
Po jakimś czasie: zdaje się, że z otwartego skoroszytu kopii nie da się zrobić taką metodą.
I jeszcze później: spróbuj jeszcze tak:
Set objFso = CreateObject("Scripting.FileSystemObject")
objFso.CopyFile "C:........\motyle.xlsx", "C:\......\motyle2.xlsx"
Set objFso = Nothing
Kill "C:\.......\motyle2.xlsx" |
|
|
napisał: VBAmator
postów: 67
umieszczony:
21 marca 2018
15:24
|
|
Rozumiem, że opcja pozyskania danych i nieotwierania pliku pomimo wszystko, nie wchodzi w grę.
A zatem najlepsza będzie opcja "kopia-dane-kill kopia". Za wszelką cenę chcę uniknąć otwierania pliku ponieważ waży sporo, otwiera się kilkanaście sekund i ma obfite workbook_open(). |
|
|
napisał: Trebor
postów: 1209
umieszczony:
20 marca 2018
18:24
|
|
| Napisz jak byś chciał aby zareagowało makro. Ma odpuścić ściąganie danych, czy też zamknąć skoroszyt źródłowy po ściągnięciu danych czy jeszcze coś innego, a może wykonać kopię skoroszytu źródłowego ściągnąć dane i usunąć kopię? |
|
|
napisał: VBAmator
postów: 67
umieszczony:
20 marca 2018
10:56
|
|
Przepraszam Trebor, ale nie zrozumieliśmy się. Pozwolę sobie wytłumaczyć innymi słowami.
Założeniem makra było pobranie danych z pliku źródłowego TEST.xlsm bez jego otwierania. Makro jest błyskawiczne i spełnia podstawowe założenie
pod warunkiem, że plik źródłowy nie jest przez nikogo używany/otwarty w momencie pozyskiwania danych.
Jeśli pracuje na nim inny użytkownik, to poniższa linijka powoduje otwarcie pliku źródłowego (oczywiście tylko do odczytu) co wychodzi poza nasze podstawowe założenie.
oCn.Open strConnectionString
W ADO mam jeszcze biały pas więc bardzo proszę o pomoc. |
|
|
napisał: Trebor
postów: 1209
umieszczony:
19 marca 2018
16:16
|
|
Należy określić pełną ścieżkę zapisu np.
'============================================================
With ThisWorkbook.Sheets(1)
For nActRow = 0 To nRowCount
If xArray(0, nActRow) = "silnik" Then '--------------------
.Cells(1, 1) = xArray(0, nActRow)
Licznik_kolumn = 1
For wiersz = nActRow - 2 To nActRow - 1
Licznik_wiersz = Licznik_wiersz + 1
For kolumna = 1 To nColCount
Licznik_kolumn = Licznik_kolumn + 1
.Cells(Licznik_wiersz, Licznik_kolumn) = xArray(kolumna, wiersz)
Next kolumna
Licznik_kolumn = 1
Next wiersz
Exit Sub 'zakładam że silnik występuje raz
End If
Next
End With
ThisWorkbook oznacza skoroszyt w którym jest makro |
|
|
napisał: VBAmator
postów: 67
umieszczony:
19 marca 2018
13:41
|
|
Manual/Automatic pomogło. Nie wiedziałem, że działa to na wszystkie otwarte okna.
Pojawił się jednak kolejny problem. Okazało się przypadkowo, że jeżeli plik źródłowy jest otwarty przez innego użytkownika w trakcie działania makra to linijka:
oCn.Open strConnectionString
powoduje otwarcie w/w pliku. W rezultacie makro swoje zadanie wykonuje w otworzonym pliku a nie w pliku wynikowym. Jeżeli plik źródłowy jest zamknięty to wszystko działa poprawnie.
Rozumiem, że da się to uwarunkować? |
|
|
napisał: Trebor
postów: 1209
umieszczony:
17 marca 2018
15:18
|
|
Być może w komputerze brakuje pamięci lub procesora.
Jednak bardziej prawdopodobne, że masz w skoroszytach wiele formuł, formuły tablicowe lub formuły odnoszące się do dużych zakresów. Na początku makra możesz przełączyć aplikację w tryb ręcznego przeliczania formuł:
Application.Calculation = xlCalculationManual
Na końcu makra przełącz na obliczanie automatyczne.
Napisz czy pomogło. |
|
|
napisał: VBAmator
postów: 67
umieszczony:
16 marca 2018
13:34
|
|
Niestety myliłem się. Wszystkie wersje działają błyskawicznie.
Spowolnienie powodują inne pliki Excel otwarte w tym samym czasie. Często obserwuję spowalnianie makr w obecności innych ActiveWindow.
To od czegoś zależy? Może da się ten problem wyeliminować? |
|
|
napisał: VBAmator
postów: 67
umieszczony:
16 marca 2018
10:58
|
|
Trafiłeś w sedno. Faktycznie ten kawałek z zamianą wartości mulił. Nawet obejście tablicą, które w końcu sam wypociłem nie pomagało.
W tej chwili niezależnie od updatingu w sekundę.
Bardzo dziękuję za pomoc. |
|
|
napisał: Trebor
postów: 1209
umieszczony:
15 marca 2018
16:30
edytowany:
15 marca 2018
16:31
|
|
Pomysł jest bardzo dobry. Jednak dla kilku zapisywanych danych różnica w czasie nie powinna aż tak znacząca. Jeśli wyłączanie odświeżania nie pomaga to może problem tkwi w konwersji danych. Spróbuj podmienić część kodu pomiędzy zielonymi liniami. Liczby przestaną być liczbami a daty datami, ale będziemy wiedzieć czy to jest ewentualna przyczyna spowalniania wykonania makra.
'============================================================
For nActRow = 0 To nRowCount
If xArray(0, nActRow) = "silnik" Then '--------------------
Cells(1, 1) = xArray(0, nActRow)
Licznik_kolumn = 1
For wiersz = nActRow - 2 To nActRow - 1
Licznik_wiersz = Licznik_wiersz + 1
For kolumna = 1 To nColCount
Licznik_kolumn = Licznik_kolumn + 1
Cells(Licznik_wiersz, Licznik_kolumn) = xArray(kolumna, wiersz)
Next kolumna
Licznik_kolumn = 1
Next wiersz
Exit Sub 'zakładam że silnik występuje raz
End If
Next
'==============================================================
Ile danych jednorazowo makro ściąga? |
|
|
napisał: VBAmator
postów: 67
umieszczony:
15 marca 2018
11:39
|
|
Działa poprawnie. Straciła jednak główny atut jakim był czas wykonania. Teraz sekundę zajmuje pobranie jednej wartości a to jest nie do zaakceptowania.
Domyślam się, że przyczyną jest strzelanie w komórki prosto z pętli. ScreenUpdating oczywiście tu nie pomaga.
Zamiast każdorazowego przekazywania danej wypełnił bym nimi tablicę i dopiero potem jednorazowo zaimportował bym całą tablicę do pliku docelowego.
Jeśli to dobry pomysł to bardzo proszę o pomoc na poziomie kodu lub ewentualnie o inne rozwiązanie pozwalające zachować szybki czas wykonania. |
|
|
napisał: Trebor
postów: 1209
umieszczony:
13 marca 2018
17:48
edytowany:
13 marca 2018
17:48
|
|
Spróbuj tak:
Option Explicit
Sub ADOGetValue()
Dim sciezka As String, plik As String, Arkusz As String, Zakres As String
Dim wiersz As Long, kolumna As Long, Licznik_wiersz As Long, Licznik_kolumn As Long
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
'-----------------------------------------------------------
sciezka = ThisWorkbook.path 'jeśli w tym samym katalogu '|
plik = "Test.xlsm" '|
Arkusz = "Ad1" '|
Zakres = "A1:G1000" '|
'-----------------------------------------------------------
If Right(sciezka, 1) <> "\" Then sciezka = sciezka & "\"
If Dir(sciezka & plik) = "" Then
'brak pliku ...
Exit Sub
End If
Set oCn = CreateObject("ADODB.Connection")
If Val(Application.Version) < 12 Then
strConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sciezka & plik & ";" & _
"Extended Properties=""Excel 8.0;HDR=NO;IMEX=1;"""
Else
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & sciezka & plik & ";" & _
"Extended Properties=""Excel 12.0;HDR=NO;IMEX=1;"""
End If
oCn.Open strConnectionString
arg = "select * from [" & Arkusz & "$" & Zakres & _
IIf(InStr(Zakres, ":") = 0, ":" & Zakres, "") & "]"
Set oRs = CreateObject("ADODB.Recordset")
oRs.Open arg, oCn, 3
xArray = oRs.getRows
oRs.Close
oCn.Close
Set oRs = Nothing
Set oCn = Nothing
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
If xArray(nActCol, nActRow) = "silnik" Then '--------------------
Cells(1, 1) = xArray(nActCol, nActRow)
Licznik_kolumn = 1
For wiersz = nActRow - 2 To nActRow - 1
Licznik_wiersz = Licznik_wiersz + 1
For kolumna = 1 To nColCount
Licznik_kolumn = Licznik_kolumn + 1
xValue = xArray(kolumna, wiersz)
If IsNumeric(xValue) Then
xValue = CDbl(xValue)
ElseIf IsDate(xValue) Then
xValue = CDate(xValue)
End If
Cells(Licznik_wiersz, Licznik_kolumn) = xValue
Next kolumna
Licznik_kolumn = 1
Next wiersz
Exit Sub
End If 'zakładam że silnik występuje raz
Next
Next
'==============================================================
End Sub |
|
|
napisał: VBAmator
postów: 67
umieszczony:
13 marca 2018
14:30
|
|
Faktycznie działa w sekundę. Jeśli chodzi o prędkość bez zarzutu.
Niestety kuleję jeszcze z tablicami więc jedyne co udało mi się zmienić w ramach adaptacji kodu to warunek na element tablicy.
Dostaję wynik w komórce Cells(1,1) ale i tak wypluwa mi w dół zadany zakres.
Function ADOGetValue(path As String, file As String, sheet As String, ref As String)
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
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 = 0 'UBound(xArray, 1)
ReDim ArrVal(1 To nRowCount + 1, 1 To nColCount + 1)
For nActRow = 0 To nRowCount
For nActCol = 0 To nColCount
If xArray(nActCol, nActRow) = "silnik" Then '--------------------
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
ArrVal(1, 1) = xValue '-------------------------------
GoTo line1 '----------------------
End If
Next
Next
line1:
ADOGetValue = ArrVal
'===============================================================
oRs.Close
oCn.Close
Set oRs = Nothing
Set oCn = Nothing
End Function
W załączniku znajduje się testowy plik źródłowy. Muszę pobrać z niego (bez otwierania) dane (data wysyłki, ilość, itd) np. dla "silnik".
Oczywiście w pliku docelowym będzie analogiczna niewypełniona matryca oczekująca na te dane.
Nie wiem jak to zgrabnie zrobić. Pomóż proszę. |
|
|
napisał: Trebor
postów: 1209
umieszczony:
12 marca 2018
18:29
|
|
Zdaje się że największą bolączką jest tutaj szybkość działania. Sprawdź rozwiązanie z ExcelForum. Testowałem na 1000 wierszach i całkiem szybko poszło.
Sub data_from_closed_file()
Range("A1:J1000") = ADOGetValue("C:\......\", "......xlsx", "Ad1", "A1:J1000")
End Sub
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
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
End Function
W Twoim makrze i w tym powyższym pod koniec powstaje tablica ArrVal. Można ją przeszukać i wybrać odpowiednie dane do zapisania w arkuszu.
Czy o to chodziło? |
|
|
napisał: VBAmator
postów: 67
umieszczony:
12 marca 2018
10:52
edytowany:
12 marca 2018
10:53
|
|
Sub data_from_closed_file()
Application.ScreenUpdating = False
p = "\\sciezka..."
f = "Excel.xlsx"
S = "Ad1"
zakres = Range(Range("D1").Offset(0, -3), Range("D1").Offset(7, -1)).Address
Range("A1:C8") = GetValue(p, f, S, zakres)
End Sub
Private Function GetValue(path, file, sheet, ref) As Variant
Dim arg As String
Dim nRow, nCol
Dim nRowCount, nColCount
Dim nActRow, nActCol
Dim ArrVal() As Variant
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = CVErr(2042)
Exit Function
End If
nRow = Range(ref).Row
nCol = Range(ref).Column
nRowCount = Range(ref).Rows.Count
nColCount = Range(ref).Columns.Count
ReDim ArrVal(1 To nRowCount, 1 To nColCount)
For nActRow = 1 To nRowCount
For nActCol = 1 To nColCount
arg = "'" & path & _
"[" & file & "]" & _
sheet & "'!" & _
"R" & nRow + nActRow - 1 & _
"C" & nCol + nActCol - 1
t = ExecuteExcel4Macro(arg)
ArrVal(nActRow, nActCol) = IIf(t = 0, "", t)
Next
Next
GetValue = ArrVal
End Function |
|
|
napisał: Trebor
postów: 1209
umieszczony:
9 marca 2018
16:42
|
|
| Zdaj się, że GetValue istnieje w wielu odmianach. Zamieść na forum wariant wykorzystywany przez Ciebie. |
|
|
napisał: VBAmator
postów: 67
umieszczony:
9 marca 2018
10:58
|
|
Cześć.
Zaadaptowałem funkcję GetValue do pobierania danych z zamkniętego pliku. Działa wolno ale działa. Niestety jedynie dla zdefiniowanego zakresu lub komórki.
Potrzebuję uzależnić pobieranie od wyszukania odpowiedniej komórki, sprawdzenia dla niej warunku i dopiero wtedy powiedzmy offsetem jakiś określony obszar pobrać.
Czy jest to możliwe?
Byłbym wdzięczny za jakiś przykład dydaktyczny... |
|
|
 wstecz 1 dalej  wszystkich stron: 1
|
|
TEST.xlsm