Příspěvky uživatele

urcite na jednom PC uz viem o com hovori. v visual studiu by som hladal excel application ale v VBA este neviem ci nato je prikaz :) dam vediet ked to najdem

tu prikladam dve moznosti prva je kde pozera vsetky otvorene workbook a do kazdeho ineho to hodi. druha moznost je presne definovana oblast.

Sub test1()
Dim aExcel As Workbook
Dim aSheet As Worksheet
Range("A3:I10").Copy
For Each aExcel In Workbooks
If Not aExcel Is ThisWorkbook Then aExcel.ActiveSheet.Paste
Next
End Sub

Sub test2()
Range("A3:I10").Copy
Windows("test2.xlsx").Activate
Range("A3").Select
ActiveSheet.Paste
End Sub

ulozte to ako CSV .... to je iste ako TXT

asi lepsie to bude kontrolovat bunka po bunke a potom to len s unionom spojit tak ako je to v tomto priklade:

https://stackoverflow.com/questions/45705044/select-and-copy-multiple-ranges-with-vba

v exceli kombinacia Ctrl+R uz je zabrana microsoftom mozte pouzit inu kombinaciu.

nastavenie skratky je mozne pri samotnom Record Macro alebo pri uz existujucom makre a to tak ze pojdete do:
1. ribbon: View potom zalozka: Macros tam stlacite View macros zo zoznamu vyberete makro ktoremu chcete dat skratku a stlacite Options

ano,

FromPath = Range("A1")
ToPath = Range("A2")

nasiel som funkciu ktora vie pocitat az do 10000 a pretoze rimske cislice koncia s M = 1000 tak myslim ze viac pocitat v tom nieje potrebne.

autor: Christian d'Heureuse
Link: https://www.source-code.biz/snippets/vbasic/7.htm

skuste toto:

Sub copy_data()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim Fdate As Date
Dim FileInFromFolder As Object
Dim aBool As Boolean

aBool = False
FromPath = ThisWorkbook.Path & "\01\" 'Source files
ToPath = ThisWorkbook.Path & "\02\" 'Target destination
Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(FromPath) = False Then aBool = True
If FSO.FolderExists(ToPath) = False Then aBool = True
If FSO.FolderExists(ToPath & "\B\") = False Then aBool = True
If FSO.FolderExists(ToPath & "\C\") = False Then aBool = True
If FSO.FolderExists(ToPath & "\D\") = False Then aBool = True
If aBool Then
MsgBox "folders doesn't exist"
Exit Sub
End If

For Each FileInFromFolder In FSO.getfolder(FromPath).Files
If Left(FileInFromFolder.Name, 1) = "0" Then FileInFromFolder.Copy ToPath & "\B\"
If Left(FileInFromFolder.Name, 1) = "1" Then FileInFromFolder.Copy ToPath & "\C\"
If Left(FileInFromFolder.Name, 1) = "3" Then FileInFromFolder.Copy ToPath & "\D\"
Next

End Sub

a nemozete to riesit klasicky nie typom:

1, 25, 26, 27
2, 28, 29, 30
3, 31, 32, 33
...

ale takto ako clovek?

1, 25
1, 26
1, 27
2, 28
2, 29
2, 30
3, 31
3, 32
3, 33
...

ked budete mat takto riesenu tabulku tak uz bude jednoduche k tomu spravit combobox

asi mate makro typu:

if Range("M8") <> "" then tisk end if
if Range("F9") <> "" then tisk end if
if Range("F18") <> "" then tisk end if

ale musite to napisat takto:

if Range("M8") <> "" and Range("F9") <> "" and Range("F18") <> "" then tisk end if

mozte spravit vseliake mozne zabezpecenia ale excel nato nieje vytvoreny.

Co vam mozem poradit zacnite pouzivat MS Access alebo skuste vytvorit online dokument napr. od google:
https://www.google.com/sheets/about/

takto nadialku neviem poradit.

no hadam ze niekto to tu vyskusa a zisti vcom je problem

a vypise vam to nejaky error alevo nieco?

lebo som to skusal u seba a funguje to dobre

kod:
Dim aIndex As Integer

Sub aVlozit()
Dim aPath As String
Dim FSOLibrary As FileSystemObject
Set FSOLibrary = New FileSystemObject

aPath = "C:\data\Rodina"
aIndex = 2
LoopAllSubFolders FSOLibrary.GetFolder(aPath)
End Sub

Private Sub LoopAllSubFolders(aFolder As Folder)
Dim aSubFolder As Folder
Dim aFile As File

For Each aSubFolder In aFolder.SubFolders
LoopAllSubFolders aSubFolder
Next
For Each aFile In aFolder.Files
If aFile.Type = "JPG File" Then
Range("B" & aIndex).Hyperlinks.Add Anchor:=Range("B" & aIndex), Address:=aFile.Path, TextToDisplay:=Replace(LCase(aFile.Name), ".jpg", "")
aIndex = aIndex + 1
End If
Next
End Sub

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje