Příspěvky uživatele

Tak som to dokumal :tady pro vse co maji podobny problem a tiez zacinaju s VBA

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 worksheets to values if you want
' For Each sh In Destwb.Worksheets
' sh.Select
' With sh.UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
' Destwb.Worksheets(1).Select
' Next sh

'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 = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
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

Ahoj Mam udelane makro na odosielanie mailu bohuzial sa my nejak nedary pridat prilohu klidne by stacil aktualnzy sheet a automaticky odoslat bez toho aby som to musem odkliknut (send):

Dik za kazdy nazor

Sub Blue_mail()

Set Outlook_Aplication = CreateObject("Outlook.Application")
Set Outlook_Aplication_MAPI = Outlook_Aplication.GetNamespace("MAPI")
Set Outlook_Aplication_ITEM = Outlook_Aplication.CreateItem(0)

Outlook_Aplication_ITEM.Importance = olImportanceHigho

Outlook_Aplication_ITEM.Display
'olMail.Display

Const olFormatHTML As Integer = 2
Const olMail As Integer = 43
Dim oOL As Object, oInsp As Object

Dim SourceTO As String
Dim SourceCC As String
Dim SourceSU As String
Dim SourceBody As String

SourceTO = Sheets("Blue").Range("A1")
SourceCC = Sheets("Blue").Range("A2")
SourceSU = Sheets("Blue").Range("A3")
SourceBody = Sheets("Blue").Range("A4")

Set oOL = CreateObject("Outlook.Application")
instance
Set oInsp = oOL.ActiveInspector

oInsp.CurrentItem.BodyFormat = olFormatHTML

Outlook_Aplication_ITEM.To = SourceTO
Outlook_Aplication_ITEM.CC = SourceCC
Outlook_Aplication_ITEM.Subject = SourceSU
Outlook_Aplication_ITEM.Body = SourceBody

'Outlook_Aplication_ITEM.Send
End Sub

Moc dil este som to trocha upravil aby to ukladalo pod nazvom s bunky npr :C6 tohle usetry moc casu v praci

ukladat 30listouv.

Damlepsi dotaz ak by som chcel ulozit len lisky ktore maju v ("B3") hodnotu vedsiu ako 1 klidne ich muzebyt 30. Vzdy ulozit podla nazvu v A1 v danom liste.

AHoj Mam dotaz Mam subor s 30 listami potrebujem ulozit len ten ktory mam prave otvoreny pri tomto my to
uklada cely subor s 30lis :

Sub ulozit()
ChDir "C:\" 'cesta kam se má soubor uložit
ActiveWorkbook.SaveAs Filename:=Range("A1")
End Sub

Dakujem pekne toto je lepsia varianta povodne co si my navrhol som este predelal ale pri zadani inej hodnoty my to mazalo povodny s pola a prepisovalo do druheho a delalo bordel v dalsom sheete kde som mam tieto hodnoty s danych poli nalinkovane.

Este ras dik si borec.

Ahoj mam otazku mam macro na triedenie podla zadanej dodnoty diky JAZA.M. Potreboval bych este nejak aktualizovat data pri zmene hodnoty. Pri opetovnom zadani zmene pola vytvara duplicita. Viac prispevok FILTER .

Vzor tady :

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo x
If Target.Column = 4 Then
Dim sl As Single
Dim rd As Single
Select Case Target.Value
Case Is = 1
sl = 8
Case Is = 2
sl = 13
Case Is = 3
sl = 18
Case Is = 4
sl = 23
End Select
rd = 4
Do While Cells(rd, sl) <> ""
rd = rd + 1
Loop
Cells(rd, sl) = "'" & Cells(Target.Row, 1)
Cells(rd, sl + 1) = "'" & Cells(Target.Row, 2)
Cells(rd, sl + 2) = Cells(Target.Row, 3)

End If
x:
End Sub

este mam jeden dotaz slo by nejak este upravit ? Ked tam zadam napr :1 a pak prepisem na inu cize 2,3,4 sa pole aktualizuje a nezapise to ako duplicitu na ine pole ?

To jo

na zaciatku som potreboval len zozrtiedit jeden stlpec podla zadanej hodnoty.

Dik za priklad

Ahoj prikladam priklad snad to dava nejaky zmysel

Nieco uz mam rozdelane uvidim k comu dospejem.

Dalsim napadom sa nebranim

jj to de ale len pokial v danych bunkach nieje vzorec. potrebujem aby sa to vzdy pri zmene v stlpci vse automaticky menilo

Ahoj mam mensi dotas. V tabulke npr. A2 az A52 su zadane hodnoty nie vsak v kazdej bunke. Potrebujem nejak filtrovat data do inej tabulky bez praznych buniek slo by to ?

Diky moc ...ani nevies ako si my pomohol

Este ras dik ..

otazka znie jak to zapsat

jde o to ze ak sa pomylis a adklepnes zapsat tak sa nevedia vratit. preto tam chcem nacpat makro na smazanie poslednych hodnot. nejak sa nedary som do toho lama

Zdravim som zaciatocnik potrebujem nejak udelat makro na smazanie poslednych zadanych hodnot. Tieto hodnoty sa zapisuju vzdy podseba. makro na zapis nejak takto :

Sub zapsat()

'

'
Dim hodnota(6)

hodnota(0) = Cells(4, 15)
hodnota(1) = Cells(5, 15)
hodnota(2) = Cells(6, 15)
hodnota(3) = Cells(7, 15)
hodnota(4) = Cells(8, 15)
hodnota(5) = Cells(9, 16)

Dim rd As Single

rd = 62

Do While Cells(rd, 1) <> ""
rd = rd + 1

Loop:

Cells(rd, 1) = hodnota(0)
Cells(rd, 2) = hodnota(1)
Cells(rd, 3) = hodnota(2)
Cells(rd, 4) = hodnota(3)
Cells(rd, 5) = hodnota(4)
Cells(rd, 6) = hodnota(5)

End Sub

Příspěvky uživatele

Uživatelské menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje