Tietojen haku kansiossa olevista työkirjan tietyistä soluista

annnnita kirjoitti:

Moi,

Ihania ootte jos pystytte auttamaan. Omat Makro-Vba-ohjelmointi taidot ovat alkeelliset ja osaan hieman jotain perusteita, mutta tämä menee yli. Kiitos jo etukäteen kaikille auttajille.

Tavoitteena on hakea taulukkoon tietystä kansiosta, jonka hakemistopolku on kirjoitettu soluun A1, ja sen kansion kaikista *.xlsx tiedostoista tietoa. Riville 2 alkaen sarakkeeseen A tulee tiedostonnimi, sarakkeeseen B haetun tiedoston solun L12 arvo, sarakkeeseen C haetun tiedoston solun D10 arvo ja sarakkeeseen D haetun tiedoston solun D12 arvo. Riville kolme seuraavan tiedoston samat tiedot ja niin edelleen.

Tarkkailtavissa kansioissa on noin 50 tiedostoa per kansio. Tiedot ovat kaikissa tiedostoissa samoissa kohdissa: ensimmäisessä taulukossa soluissa L12, D10, D12.

Tämmöisen koodin löysin netistä, mutta en saa sitä toimimaan. Solujen L12, D10, D12 arvot eivät kopioidu koontitaulukkoon.

-------------------------------------------------------

Option Explicit
Public strSourceFldr As String
Public EachFile As Object
Public objFSO As Object
Public objFolder As Object
Public objFile As Object
Public strSheetName As String
Public strSrcCell1 As String
Public strSrcCell2 As String
Public strSrcCell3 As String
Public intStartCell As Integer
Sub DataCopy()
strSourceFldr = Worksheets(1).Cells(1, 1)
strSheetName = "Taul1"
strSrcCell1 = "L2"
strSrcCell2 = "D10"
strSrcCell3 = "L12"
intStartCell = 2
Set objFSO = CreateObject("Scripting.Filesystemobject")
Set objFolder = objFSO.GetFolder(strSourceFldr)
For Each EachFile In objFolder.Files
If LCase(objFSO.GetExtensionName(EachFile)) = "xlsx" Then
ProcessFile EachFile
End If
Next
ProcessSubFolder objFSO.GetFolder(strSourceFldr)
End Sub
Sub ProcessFile(ByRef ThisFile As Object)
Dim Cell1, Cell2, Cell3
Set objFile = objFSO.GetFile(ThisFile)
Workbooks.Open ThisFile
MsgBox strSrcCell1
Cell1 = Range(strSrcCell1).Value
Cell2 = Range(strSrcCell2).Value
Cell3 = Range(strSrcCell3).Value
ActiveWorkbook.Close
Worksheets(1).Cells(intStartCell, 1) = ThisFile.Name
Worksheets(1).Cells(intStartCell, 2) = Cell1
Worksheets(1).Cells(intStartCell, 3) = Cell2
Worksheets(1).Cells(intStartCell, 4) = Cell3
intStartCell = intStartCell 1
End Sub
Sub ProcessSubFolder(ByRef ThisFolder As Object)
Dim SubFolder
For Each SubFolder In ThisFolder.SubFolders
Set objFolder = objFSO.GetFolder(SubFolder.Path)
For Each EachFile In objFolder.Files
If LCase(objFSO.GetExtensionName(EachFile)) = "xlsx" Then
ProcessFile EachFile
End If
Next
ProcessSubFolder objFolder
Next
End Sub

---------------------------------------------

Kiitos

kirjoitti:

Anonyymi

Kirjoita kommentti

5000

Lähetä