Příspěvky uživatele

Třeba takhle?

Mohlo by to být takhle?

Je to jen na rychlo.

Bohužel jsem pracovně vytížený a nemám čas.

Tak?

Poradit ti někdo může, ale bez přílohy těžko.

Já se omlouvám, ale vůbec teď nemám čas.

Elnino klidně do toho mluv, to co jsem se naučil, tak je od tebe.

A nešla by využít cesta k souboru?

CESTA = ThisWorkbook.Path

To vypadá jako moje makro.

Sub Import()

Dim CESTA As String
Dim SOUBOR As String
Dim ZDROJ As String
Dim CIL As String
Dim RADEK As Long
Dim POCET As Long
Dim wsDATA As Worksheet
Dim objNetwork As Object

Set wsDATA = Worksheets("List1")
Set objNetwork = CreateObject("WScript.Network")

PCN = objNetwork.ComputerName
Set objNetwork = Nothing

POCET = wsDATA.Cells(Rows.Count, "A").End(xlUp).Row

If POCET > 0 Then wsDATA.Range("A2").Resize(POCET, 3).ClearContents

MESIC = wsDATA.Range("E1")
CILMESIC = Sheets("Report").Range("B1")

CESTA = "C:\Users\" & PCN & "\Documents\MEGA\import\Report\"
ZDROJ = "Report " & MESIC & ".xlsx"
CIL = "Vyučtovanie " & CILMESIC & ".xlsm"

SOUBOR = CESTA & ZDROJ

If Dir(SOUBOR) = "" Then MsgBox "Soubor " & SOUBOR & " neexistuje!", vbCritical: Exit Sub

Application.ScreenUpdating = False
Workbooks.Open Filename:=SOUBOR
POCET = Workbooks(ZDROJ).Sheets("Položky dokladu").Cells(Rows.Count, "A").End(xlUp).Row - 2
Workbooks(CIL).Sheets("List1").Range("A2").Resize(POCET, 3).Value = Workbooks(ZDROJ).Sheets("Položky dokladu").Range("B3").Resize(POCET, 3).Value
Workbooks(ZDROJ).Close SaveChanges:=False
Application.ScreenUpdating = True

ActiveWorkbook.RefreshAll

End Sub

Sub makro()

Dim objNetwork As Object
Set objNetwork = CreateObject("WScript.Network")

PCN = objNetwork.ComputerName

Set objNetwork = Nothing

CESTA = "C:\Users\" & PCN & "\Documents\MEGA\import\Report"

End Sub

Já se tím už nezaobíral, když jsem viděl, že to máš hotové.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim KeyCells As Range
Set KeyCells = Range("A1:C1")

If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then

If Range("A1").Value > "" And Range("A1").Value = 0 And Range("B1").Value > "" And Range("B1").Value = 0 And Range("C1").Value > "" And Range("C1").Value = 0 Then
Range("D1").Interior.Color = vbRed
Else
Range("D1").Interior.Pattern = xlNone
End If

End If

End Sub

nevím jestli jsem to pochopil.

Private Sub CheckBox1_change()

If CheckBox1.Value = True Then

i = MsgBox("Při zapnutí dojde k vynulování všech uložených hodnot. Pokračovat?", vbYesNo + vbExclamation, "Varování!")
Select Case i
Case vbYes
Call Reset

Case vbNo
CheckBox1.Value = False
MsgBox "Bla bla", vbCritical
End Select

ElseIf CheckBox1.Value = False Then
Exit Sub
End If

End Sub

Nejde mi to stáhnout. zaregistruj se a dej přílohu sem.

Není za co.

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje