doplnění VBA - odstranit filtry... Vyřešeno

[mejlacz]

Ahoj všem,

před časem jste mi tu pomohli s tvorbou makra na sběr dat z několika souborů do jedné souhrné tabulky. Potřeboval bych ale doplnit do tohoto makra ještě dvě věci:

1) pokud existuje v podkladových souborech filtr, tak aby byl odstraněn
2) pokud existují skryté sloupce/řádky, tak aby se zobrazili

teprve potom aby došlo k natáhnutí dat z konkrétního souboru.

Makro:

Option Explicit

Sub SloucitData()
Dim MsgResponse As Byte
Dim objFSO As Object, objDir As Object, aItem As Object
Dim CntFFile As Integer, SPath As String, SFileType
Dim Swbk As Workbook, SWsht As Worksheet, SCll As Range
Dim SWshtName As String, SCllAddr As String
Dim TWbk As Workbook, TWsht As Worksheet, TCllAddr As String
Dim TCll As Range, TOffsR As Long, TWshtName As String
Dim CopyRow, CopyRows As Long

'*********upravit dle realu**********
SPath = "M:\Pur\A_PROJECT CONTROL SHEET (PCS)\PRO KOMODITNÍ NÁKUP\bak" ' katalog zdrojovych sesitu
SFileType = "xlsx" ' rozsireni .xlsx
' nazev listu a vychozi bunka
SWshtName = "Project" ' zdrojovych sesitu
SCllAddr = "a2:cu2"
TWshtName = "Projecty" ' ciloveho sesitu
TCllAddr = "a2:cu2"
'************************************

' v katalogu otevirat jednotlive soubory, prenest data
' definovat objekt FSO
Set objFSO = CreateObject("scripting.filesystemobject")
On Error Resume Next
' katalog
Set objDir = objFSO.GetFolder(SPath)
If Err.Number <> 0 Then
MsgResponse = MsgBox("Katalog zdrojových souboru nebyl nalezen." & vbCr _
& "Konec.", vbOKOnly + vbExclamation)
GoTo Err3
End If
On Error GoTo 0
' pocet souboru
CntFFile = objDir.Files.Count
' pokud CntFFile=0, zobrazi hlasku
If CntFFile > 0 Then
' definovat cilovy sesit, list, vychozi bunku, offset
Set TWbk = ThisWorkbook
Set TWsht = TWbk.Worksheets(TWshtName)
Set TCll = TWsht.Range(TCllAddr)
TOffsR = 0
' ve smycce otevirat zdrojove sesity
For Each aItem In objDir.Files
If objFSO.GetExtensionName(aItem) = SFileType Then
' definovat zdrojovy sesit, list, vychozi bunku














Set Swbk = GetObject(aItem)
Set SWsht = Swbk.Worksheets(SWshtName)
Set SCll = SWsht.Rows(1)
' pocet obsazených řádků dle 1. sloupce
CopyRows = SWsht.Cells(Rows.Count, 1).End(xlUp).Row - 1
' ve smycce otevirat kopirovat radky sesitu
For CopyRow = 1 To CopyRows
' prenest data
TCll.Offset(TOffsR, 0).Value = SCll.Offset(CopyRow, 0).Value
TOffsR = TOffsR + 1
Next CopyRow

Swbk.Close False ' zavrit zdrojovy sesit
Set SCll = Nothing
Set SWsht = Nothing
Set Swbk = Nothing
End If
Next aItem
With Application
.DisplayAlerts = False
TWbk.Save ' ulozit cilovy sesit
.DisplayAlerts = True
End With
Else ' nebyl nalezen zadny soubor
MsgResponse = MsgBox("Katalog zdrojových souboru: '" & SPath & "' je prázdný!", _
vbOKOnly + vbInformation)
End If
Set TCll = Nothing
Set TWsht = Nothing
Set TWbk = Nothing
Err3:
Set aItem = Nothing
Set objDir = Nothing
Set objFSO = Nothing
End Sub

Děkuji,

Mejlacz

[Reklama]

[cmuch]

Zkus vložit toto

Kód: Vybrat vše

    SWsht.AutoFilterMode = False
    SWsht.Cells.EntireRow.Hidden = False
    SWsht.Cells.EntireColumn.Hidden = False

tady za to

Kód: Vybrat vše

Set Swbk = GetObject(aItem)
Set SWsht = Swbk.Worksheets(SWshtName)

Nevím zda to bude fungovat, nezkoušel jsem.

[mejlacz]

Funguje, paráda. Teď už jenom přijít na to, jak Ti poslat pivo, na dálku :)