Příspěvky uživatele

ono by stačilo myslím

http://wall.cz/excel-navod/formular-pro-zadavani-dat

a šlo by to i bez maker nesplňuje sice na jiný list ale to je detail

použil bych záznam makra a naimportoval požadovaný soubor

Díky moc funguje super

díky moc za tipy o match jsem uvažoval ale bohužel hodnoty nebyli řazeny tak před použitím nechám seřadit

Ahoj,

možná triviální dotaz ale nějak na to nemohu přijít jakým způsobem najít pozici nejmensí hodnoty za určitou položku viz příloha

viz cmuch

http://wall.cz/index.php?m=topic&id=19777

zkus toto nemám přístup k utlouku

Option Explicit

Sub AddToOutlook()

Dim OL As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim colItems As Outlook.Items
Dim olApptSearch As Outlook.AppointmentItem
Dim r As Long, sSubject As String, sBody As String, sLocation As String
Dim dStartTime As Date, dEndTIme As Double, dReminder As Double, dCatagory As Double
Dim sSearch As String, bOLOpen As Boolean

On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
bOLOpen = True
If OL Is Nothing Then
Set OL = CreateObject("Outlook.Application")
bOLOpen = False
End If
Set NS = OL.GetNamespace("MAPI")
Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items

For r = 2 To 10

If Len(Sheet1.Cells(r, 2).Value & Sheet1.Cells(r, 1).Value) = 0 Then Goto NextRow
sSubject = Sheet1.Cells(r, 2).Value
sBody = Sheet1.Cells(r, 5).Value
dStartTime = Sheet1.Cells(r, 1).Value
dEndTIme = Sheet1.Cells(r, 4).Value
sLocation = Sheet1.Cells(r, 6).Value
dReminder = 120

sSearch = "[Subject] = " & sQuote(sSubject)
Set olApptSearch = colItems.Find(sSearch)

If olApptSearch Is Nothing Then
Set olAppt = OL.CreateItem(olAppointmentItem)
olAppt.Body = sBody
olAppt.Subject = sSubject
olAppt.Start = dStartTime
olAppt.Duration = dEndTIme
olAppt.Location = sLocation
olAppt.Catagory = dCatagory
olAppt.Close olSave
End If

NextRow:
Next r

If bOLOpen = False Then OL.Quit

End Sub

Function sQuote(sTextToQuote)
sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function

myslel jsem že to co tam máš vytvořeno ti funguje a chceš ošetřit aby ti to nespustily lidi dvakrát

viděl bych to stávájící makro hodit do modulu a poté vymazat modul viz

http://wall.cz/index.php?m=topic&id=5237

co takto ??? pracuje to tedy s active cell ale snad pomůže nereaguje na tu podmiňovanou 1 ale to se dá doladit :-) je to upravený kód od "ALa" možná by stálo za to pročíst

http://wall.cz/index.php?m=topic&id=19012#post-19055

Sub Pom13()
Dim colToCopy As Integer, rngToCopy As Range, najdi As String

najdi = Cells(2, ActiveCell.Column)

With Sheets("slova")
colToCopy = WorksheetFunction.Match(najdi, .[a3584:p3584], 0)
Set rngToCopy = .Cells(3585, colToCopy)
Set rngToCopy = rngToCopy.Resize(WorksheetFunction.CountA(.Columns(colToCopy)), 1)
End With
rngToCopy.Copy (Sheets("tabulka").Cells(7, ActiveCell.Column))

Set rngToCopy = Nothing
End Sub

opravdu to je na přílohu místo citlivých dej nějaké obecné a je to

po zrušení linku na axecell je to opravdu jako obrázek ale možná tady na této stránce je něco užitečného moc se v tom neorientuji
http://stackoverflow.com/questions/7810234/macro-in-powerpoint-which-links-to-data-stored-in-an-excel-spreadsheet

nebo nepřímý odkaz=NEPŘÍMÝ.ODKAZ("b" & c1)

tak na tohle to chce určitě přílohu

nebo takto odešle aktivní list na mail zadaný přímo v kódu:
Sub Email1()
'Working in 2000-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2010
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = ""
.CC = ""
.BCC = ""
.Subject = " " & Format(Now - 1, "dd.mm.yyyy")
Rem .Body = "Hi there"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.send 'or use .display
End With
On Error GoTo 0
.Close savechanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje