- Akciófigyelő: Humble Games Bundle - Nightdive FPS Remasters
- Call of Duty: Modern Warfare III - Új szezon, újabb ingyenes hétvége jön
- Hunt: Showdown - Jön az engine csere, befutnak az újgenerációs verziók
- Steamre tart a Crime Boss: Rockay City
- The Witcher - Befutott a TV sorozat folytatásának első rövid kedvcsinálója
-
GAMEPOD.hu
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
lappy
őstag
válasz medvezsolt #14436 üzenetére
Szia!
Ha fgv.-el ezt nem tudod megcsinálni csak macroval!Bámulatos hol tart már a tudomány!
-
lappy
őstag
válasz basaharc502 #14469 üzenetére
Szia!
Igazából ez nem is excel probléma!
A tanácsom a következő:
- egyesével vidd be az évszámokat
- majd tedd be az eseményt
Na most következik a trükk!
az animálásnál kell beállítani a következőket
(az évszámokat akár egyesével kattintásra hozhatod be vagy már mind látszik ezt rád bízom)
az egyik eseményt kiválasztva be lehet állítani hogy milyen animációval és mire induljon el
jobb gomb majd effektus beállítása
időzítés (a képen láthatod hogy mit is kell beállítani)
remélem segítettem![ Szerkesztve ]
Bámulatos hol tart már a tudomány!
-
lappy
őstag
válasz dellfanboy #14473 üzenetére
Szia!
Alap esetben nem! De sok fáradságos és kitartó munkával igen!
[link]
vagy ez a módszer!
Először mindenképpen át kell konvertálni pl. word formátumúvá.
(persza ha kinyomtatott doksi lett szkennelve és úgy lett pdf, akkor sokkal macerásabb lesz a visszakonvertálás, minta a dokumentum közvetlenül pdf-be került nyomtatásra)Bámulatos hol tart már a tudomány!
-
lappy
őstag
válasz zseszter0705 #14484 üzenetére
Szia!
Ha elmented és újra indítod akkor is ugyanez van?Bámulatos hol tart már a tudomány!
-
lappy
őstag
válasz lacipapi #14530 üzenetére
Szia!
Sub SaveWorkbookBackup()
Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean
If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub
Set awb = ActiveWorkbook
If awb.Path = "" Then
Application.Dialogs(xlDialogSaveAs).Show
Else
BackupFileName = awb.FullName
i = 0
While InStr(i + 1, BackupFileName, ".") > 0
i = InStr(i + 1, BackupFileName, ".")
Wend
If i > 0 Then BackupFileName = Left(BackupFileName, i - 1)
BackupFileName = BackupFileName & "_masolat" & ".xls"
OK = False
On Error GoTo NotAbleToSave
With awb
Application.StatusBar = "Munkafüzet mentése"
.Save
Application.StatusBar = "Munkafüzet mentése..."
.SaveCopyAs BackupFileName
OK = True
End With
End If
NotAbleToSave:
Set awb = Nothing
Application.StatusBar = False
If Not OK Then
MsgBox "Biztonsági másolat nem kerül mentésre!", vbExclamation, ThisWorkbook.Name
End If
End SubBámulatos hol tart már a tudomány!
-
lappy
őstag
válasz Bocimaster #14557 üzenetére
Az attól függ milyen az adathalmaz, de a BIN2DEC fgv próbálkozz!
Bámulatos hol tart már a tudomány!
-
lappy
őstag
Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
Sub ChDirNet(szPath As String)
SetCurrentDirectoryA szPath
End Sub
Sub Combine_Workbooks_Select_Files()
Dim MyPath As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim SaveDriveDir As String
Dim FName As Variant
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
SaveDriveDir = CurDir
ChDirNet "C:\"
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
If IsArray(FName) Then
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
For Fnum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(FName(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:A25")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Not enough rows in the sheet. "
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
Set destrange = BaseWks.Range("A" & rnum)
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
ChDirNet SaveDriveDir
End SubBámulatos hol tart már a tudomány!
-
lappy
őstag
válasz Bocimaster #14589 üzenetére
Szia!
Ha jól gondolom akkor ilyet szeretnél!
Minden le van írva, hogy hogyan kell!
[link]Bámulatos hol tart már a tudomány!
-
lappy
őstag
válasz Bocimaster #14596 üzenetére
Az elején létrehozod a diagramot és utána kellenek azok a lépések!
Bámulatos hol tart már a tudomány!
-
lappy
őstag
Sub CallMailer()
Dim lngLoop As Long 'Programming ethics 1. Always start your first line after leaving a line space, and 1 indentation level
With ActiveSheet
For lngLoop = 2 To .Cells(Rows.Count, 1).End(xlUp).Row ' Programming ethics 3. Always indent your loops, case statements and with constructors
Call SendMessage(strTo:=.Cells(lngLoop, 1).Value, strCC:=.Cells(lngLoop, 2).Value, strBCC:=.Cells(lngLoop, 7).Value, strMessage:=.Cells(lngLoop, 8).Value, strSubject:=.Cells(lngLoop, 3).Value, strAttachmentPath:=.Cells(lngLoop, 6).Value, rngToCopy:=.Cells(lngLoop, 9))
Next lngLoop
End With 'Programming ethics 2. Always end your last line leaving a line space before ending the sub or function, and having indendation level of 1
End Sub
Sub SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional strAttachmentPath As String, Optional rngToCopy As Range, Optional blnShowEmailBodyWithoutSending As Boolean = False)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
Exit Sub
End If
' Create the Outlook session.
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo -1: On Error GoTo 0
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
End If
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
If Trim(strTo) <> "" Then
Set objOutlookRecip = .Recipients.Add(strTo)
objOutlookRecip.Type = olTo
End If
' Add the CC recipient(s) to the message.
If Trim(strCC) <> "" Then
Set objOutlookRecip = .Recipients.Add(strCC)
objOutlookRecip.Type = olCC
End If
' Add the BCC recipient(s) to the message.
If Trim(strBCC) <> "" Then
Set objOutlookRecip = .Recipients.Add(strBCC)
objOutlookRecip.Type = olBCC
End If
' Set the Subject, Body, and Importance of the message.
If strSubject = "" Then
strSubject = "This is an Automation test with Microsoft Outlook"
End If
.Subject = strSubject
If strMessage = "" Then
strMessage = "This is the body of the message." & vbCrLf & vbCrLf
End If
.Importance = olImportanceHigh 'High importance
If Not strMessage = "" Then
.Body = strMessage & vbCrLf & vbCrLf
End If
If Not rngToCopy Is Nothing Then
.HTMLBody = .Body & RangetoHTML(rngToCopy)
End If
' Add attachments to the message.
If Not IsMissing(strAttachmentPath) Then
If Len(Dir(strAttachmentPath)) <> 0 Then
Set objOutlookAttach = .Attachments.Add(strAttachmentPath)
Else
MsgBox "Unable to find the specified attachment. Sending mail anyway."
End If
End If
' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next
' Should we display the message before sending?
If blnShowEmailBodyWithoutSending Then
.Display
Else
.Save
.Send
End If
End With
Set objOutlook = Nothing
Set objOutlookMsg = Nothing
Set objOutlookAttach = Nothing
Set objOutlookRecip = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Copy the range and create a workbook to receive the data.
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
' Publish the sheet to an .htm file.
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
' Read all data from the .htm file into the RangetoHTML subroutine.
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
' Close TempWB.
TempWB.Close savechanges:=False
' Delete the htm file.
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End FunctionBámulatos hol tart már a tudomány!
-
lappy
őstag
Szia!
Ha 2003 as excel van akkor
Aktuális dátum: Jelöljük ki a cellát, és nyomjuk meg a CTRL+. (pont) billentyűket (a szerkesztőlécen).
Aktuális idő: Jelöljük ki a cellát, és nyomjuk meg a CTRL+SHIFT+. (pont) billentyűket.Aktuális dátum és idő: Jelöljük ki a cellát, és nyomjuk meg a CTRL+. (pont), majd a Szóköz, végül a CTRL+SHIFT+. (pont) billentyűket (a szerkesztőlécen).
Újabb verzióban nem működik csak az idő!Bámulatos hol tart már a tudomány!
-
lappy
őstag
válasz Töki bácsi #14725 üzenetére
Szia!
Attól függ hogy hány összefüggés van szélesség és hosszúság között?!Bámulatos hol tart már a tudomány!
-
lappy
őstag
válasz Töki bácsi #14727 üzenetére
Én érvényesítési listával oldanám meg!
Bámulatos hol tart már a tudomány!
-
lappy
őstag
válasz Töki bácsi #14729 üzenetére
Szia!
Így talán megfelel neked!
táblázat készítése:
1. vízszintes sorba a hosszúság!
2. függőleges sorba szélesség
3. a metszéspontokba az ár!
ha ez kész, akkor:
kis táblázat ahol meg kell adni a szélességet plusz a hosszúságot
akkor kiadja az árat
a képlet hozzá:
=INDEX(B3:E6;HOL.VAN(C12;B3:E3;0);HOL.VAN(D12;B3:B6;0))
Figyelj! tömbképletnek kell lennie!!Bámulatos hol tart már a tudomány!
-
lappy
őstag
válasz marchello1 #14768 üzenetére
Szia!
Nem igazán értem a problémád de talán ez kell neked:1 2 3
P 105 =AB.SZUM($A$4:$B$10; "2";A4:A5)
S 96
C 105
P 75
S 76,8
P 45[ Szerkesztve ]
Bámulatos hol tart már a tudomány!
-
lappy
őstag
Sziasztok!
Az alábbi macrót kellene 2007 ben használnom, de nem vagyok toppon a macróban hogy hogyan tudom átalakítani.
Private Sub UserForm_Initialize()
Dim KERES As Object
Dim FILEOK() As String
Set KERES = Application.FileSearch
KERES.LookIn = "C:\TRS\Munka"
KERES.Filename = "*.xls"
If KERES.Execute > 0 Then
DARABSZAM = KERES.FoundFiles.Count
ReDim FILEOK(DARABSZAM)
For I = 1 To DARABSZAM
FILEOK(I) = KERES.FoundFiles(I)
Next I
File_lista.List = FILEOK
End If
File_lista.SetFocus
End SubBámulatos hol tart már a tudomány!
-
lappy
őstag
Erre valakinek vmi ötlete?
[link]Bámulatos hol tart már a tudomány!
-
lappy
őstag
válasz dellfanboy #14812 üzenetére
Szia!
Ha csak az ár kell mellé egy cellába akkor =b1!Bámulatos hol tart már a tudomány!
-
lappy
őstag
Szia Delila_1!
Ebben tudnál nekem segíteni!
Az alábbi macrót kellene 2007 ben használnom, de nem vagyok toppon a macróban hogy hogyan tudom átalakítani.
A cél az hogy egy gombot megnyomva könyvtárból lehessen kiválasztani egy .xls kiterjesztésű fájlt és azt betölti majd a munkalapra.!
Ez a macro viszont csak 2003 ban megy az Application.FileSearch miatt.Private Sub UserForm_Initialize()
Dim KERES As Object
Dim FILEOK() As StringSet KERES = Application.FileSearch
KERES.LookIn = "C:\TRS\Munka"
KERES.Filename = "*.xls"
If KERES.Execute > 0 Then
DARABSZAM = KERES.FoundFiles.Count
ReDim FILEOK(DARABSZAM)
For I = 1 To DARABSZAM
FILEOK(I) = KERES.FoundFiles(I)
Next I
File_lista.List = FILEOK
End IfFile_lista.SetFocus
End Sub
Bámulatos hol tart már a tudomány!
-
-
lappy
őstag
válasz Delila_1 #14831 üzenetére
Szia!
Köszönöm hogy segíteni próbálsz, de nem értem mit is kellene csinálnom!
Az értem, hogy egy gombhoz kell azt a macrot rendelni amit írtál!
De ezt nem értem "A fájlok nevét az aktuális lap A oszlopába vittem fel"
A Dim sor kiegészítést azt értem!Bámulatos hol tart már a tudomány!
-
lappy
őstag
-
lappy
őstag
válasz Dark Archon #14901 üzenetére
Szia!
A diagram kirajzoltatása még menne is, sikerül beállítani a logaritmikus skálát is, de negatív tartományban nem hajlandó kirajzolni.!
Amúgy elindítod a diagram készítőt! Az tengelyeket beállítod ha ez megvan akkor a súgóban rákeresel a logaritmikus szóra és ott lépésről lépésre leírja hogy kell átállítani.Bámulatos hol tart már a tudomány!
-
lappy
őstag
Szia!
=INT((D6-E6)/365,25)
ez kiszámolja hogy mennyi a ledolgozott idő a legközelebbi egész felé kerekítve.
A többi feladat rád vár hogy megold azt hogy ha 20 kisebb vagy nagyobb akkor hogyan változik a fizetése!
A D6 a mai nap![ Szerkesztve ]
Bámulatos hol tart már a tudomány!
-
lappy
őstag
Új hozzászólás Aktív témák
- Kerékpárosok, bringások ide!
- Radeon Anti-Lag 2 néven tér vissza az Anti-Lag+
- Milyen TV-t vegyek?
- Google Pixel 6/7/8 topik
- Politika
- Hatalmas, 16K felbontású, szemüveg nélküli 3D kijelzőt villantott a BOE
- Magisk
- Kínai, és egyéb olcsó órák topikja
- Windows 10
- Milyen program, ami...?
- További aktív témák...
Állásajánlatok
Cég: Ozeki Kft.
Város: Debrecen
Cég: Ozeki Kft.
Város: Debrecen