< návrat zpět

MS Excel

Téma: Makro len v príslušnom adresáre rss

Zaslal/a Tono 13.8.2014 12:00

Ahoj,ak by vedel niekto poradiť
mám makro kopírovanie viacerých xls súborov do jedného final , na C: mi to funguje v pre xls súbory uložených v konkrétnom adresáre tam kde mám uložené finál xls a ostaté xls súbory z ktorích kopíruje data je to v pohode , ale ak chcem aby makro fungovalo na v práci na servere v adresáre Reporty
napr: \\kedata\data1\OTD\Reporty snaží sa kopírovať súbory aj z vyšších adresárov

Application.ScreenUpdating = False

Dim hs, posledny_riadok, subor, riadok, pomocny_stlpec, x, posledny_zaznam, riadok_copy, riadok_paste
Dim pomocny_riadok, riadok_suboru

ChDir Application.ThisWorkbook.Path
hs = Application.ThisWorkbook.Name
pomocny_stlpec = 256

'zisti kde je posledny vyplneny riadok pomocny
posledny_riadok = ActiveSheet.Cells(ActiveSheet.Rows.Count, pomocny_stlpec).End(xlUp).Row
riadok_suboru = posledny_riadok + 1

x = 1
subor = Dir("")
Do While subor <> ""
'Cells(x, 5).Value = subor
x = x + 1
If subor = hs Then GoTo xx

For riadok = 1 To posledny_riadok
If Cells(riadok, pomocny_stlpec).Value = subor Then GoTo subor_uz_existuje
Next riadok

Workbooks.Open Filename:=subor
posledny_zaznam = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
riadok_paste = posledny_riadok

For riadok_copy = 9 To posledny_zaznam
Range(Cells(riadok_copy, 1), Cells(riadok_copy, 83)).Select
Selection.Copy
Windows(hs).Activate
Cells(ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row + 1, 1).Select
ActiveSheet.Paste
Windows(subor).Activate
Next riadok_copy

Windows(hs).Activate
Cells(riadok_suboru, pomocny_stlpec).Value = subor
riadok_suboru = riadok_suboru + 1
Windows(subor).Activate

Windows(subor).Close
subor_uz_existuje:
xx:
subor = Dir
Loop
ActiveWindow.SmallScroll Down:=-6
Columns("C:C").Select
Selection.Replace What:="0", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("B1").Select
End Sub

ďakujem

Zaslat odpověď >
cmuch1(13.8.2014 15:28)#021104
avatar
Vyzkousej

Sub copy()

Application.ScreenUpdating = False

Dim hs, posledny_riadok, subor, riadok, pomocny_stlpec, x, posledny_zaznam, riadok_copy, riadok_paste
Dim pomocny_riadok, riadok_suboru

hs = Application.ThisWorkbook.Name
pomocny_stlpec = 256

'zisti kde je posledny vyplneny riadok pomocny
posledny_riadok = ActiveSheet.Cells(ActiveSheet.Rows.Count, pomocny_stlpec).End(xlUp).Row
riadok_suboru = posledny_riadok + 1

x = 1
subor = Dir(Application.ThisWorkbook.Path & "\*")
Do While subor <> ""
'Cells(x, 5).Value = subor
x = x + 1
If subor = hs Then GoTo xx

For riadok = 1 To posledny_riadok
If Cells(riadok, pomocny_stlpec).Value = subor Then GoTo subor_uz_existuje
Next riadok

Workbooks.Open Filename:=Application.ThisWorkbook.Path & "\" & subor
posledny_zaznam = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
riadok_paste = posledny_riadok

For riadok_copy = 9 To posledny_zaznam
Range(Cells(riadok_copy, 1), Cells(riadok_copy, 83)).copy
Windows(hs).Activate
Cells(ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial
Windows(subor).Activate
Next riadok_copy

Windows(hs).Activate
Cells(riadok_suboru, pomocny_stlpec).Value = subor
riadok_suboru = riadok_suboru + 1
Windows(subor).Activate

Windows(subor).Close
subor_uz_existuje:
xx:
subor = Dir
Loop

Columns("C:C").Replace What:="0", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("B1").Select
End Subcitovat
Tono(21.8.2014 22:47)#021277
avatar

cmuch1 napsal/a:

VyzkousejSub copy()Application.ScreenUpdating = FalseDim hs, posledny_riadok, subor, riadok, pomocny_stlpec, x, posledny_zaznam, riadok_copy, riadok_pasteDim pomocny_riadok, riadok_suboruhs = Application.ThisWorkbook.Namepomocny_stlpec = 256'zisti kde je posledny vyplneny riadok pomocnyposledny_riadok = ActiveSheet.Cells(ActiveSheet.Rows.Count, pomocny_stlpec).End(xlUp).Rowriadok_suboru = posledny_riadok + 1x = 1subor = Dir(Application.ThisWorkbook.Path & "\*")Do While subor <> ""'Cells(x, 5).Value = suborx = x + 1If subor = hs Then GoTo xxFor riadok = 1 To posledny_riadokIf Cells(riadok, pomocny_stlpec).Value = subor Then GoTo subor_uz_existujeNext riadokWorkbooks.Open Filename:=Application.ThisWorkbook.Path & "\" & suborposledny_zaznam = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Rowriadok_paste = posledny_riadokFor riadok_copy = 9 To posledny_zaznamRange(Cells(riadok_copy, 1), Cells(riadok_copy, 83)).copyWindows(hs).ActivateCells(ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecialWindows(subor).ActivateNext riadok_copyWindows(hs).ActivateCells(riadok_suboru, pomocny_stlpec).Value = suborriadok_suboru = riadok_suboru + 1Windows(subor).ActivateWindows(subor).Closesubor_uz_existuje:xx:subor = DirLoopColumns("C:C").Replace What:="0", Replacement:="", LookAt:=xlPart, _SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ReplaceFormat:=FalseRange("B1").SelectEnd Sub


ďakujem veľmi , vyzerá to dobrecitovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.

On-line nástroje