-
Mobilarena
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
-
lcdtv
tag
Ha valakinek kellene. A cellatartalom hyperlink kell, hogy legyen (ez nálam hiba volt), mivel több száz F2+entert nem akartam nyomogatni ezért van ez a script. Ez minden cella adatból hyperlinket csinál.
Sub HyperAdd()
'Converts each text hyperlink selected into a working hyperlink
Dim xCell As Range
For Each xCell In Selection
ActiveSheet.Hyperlinks.Add Anchor:=xCell, Address:=xCell.Formula
Next xCell
End Sub
majd ez a script meg letölti egy adott könyvtárbaConst TargetFolder = "C:\temp\"
#If VBA7 And Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongPtr, _
ByVal lpfnCB As LongPtr _
) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long _
) As Long
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#End If
Public Const ERROR_SUCCESS As Long = 0
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000
Public Const folderName As String = "c:\temp\"
Sub MyFileDownload()
For Each Hyperlink In ActiveSheet.Hyperlinks
For N = Len(Hyperlink.Address) To 1 Step -1
If Mid(Hyperlink.Address, N, 1) <> "/" Then
LocalFileName = Mid(Hyperlink.Address, N, 1) & LocalFileName
Else
Exit For
End If
Next N
Call HTTPDownloadFile(Hyperlink.Address, TargetFolder & LocalFileName)
LocalFileName = “”
Next Hyperlink
End Sub
Sub HTTPDownloadFile(ByVal URL As String, ByVal LocalFileName As String)
Dim Res As Long
On Error Resume Next
Kill LocalFileName
On Error GoTo 0
Res = URLDownloadToFile(0&, URL, LocalFileName, 0&, 0&)
End Sub
Sub bcvb()
End Sub -
lcdtv
tag
Sziasztok! Szeretnék egy Excel fájlból ahol az "A" oszlopban több száz pdf link van letöltést csinálni egy adott könyvtárba. Több példát is néztem de nem jön össze.
Lehet az a hiba hogy https-ről kellene tölteni?
Annyit csinál csak hogy a "C" oszlopba a "Unable to download the file" szöveget teszi minden fájl mellé.Option Explicit
#If VBA7 And Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongPtr, _
ByVal lpfnCB As LongPtr _
) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long _
) As Long
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#End If
Public Const ERROR_SUCCESS As Long = 0
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000
Public Const folderName As String = "c:\temp\"
Sub downloadImages()
Dim i As Long, ret As Long, sWAN As String, sLAN As String
With Worksheets("Munka1")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
sLAN = folderName & .Cells(i, 1).Value & ".pdf"
sWAN = .Cells(i, 2).Value
ret = URLDownloadToFile(0&, sWAN, sLAN, BINDF_GETNEWESTVERSION, 0&)
If ret = 0 Then
.Cells(i, 3) = "File successfully downloaded"
Else
.Cells(i, 3) = "Unable to download the file"
End If
Next i
End With
End Sub -
lcdtv
tag
válasz
Teejay83
#39033
üzenetére
Nekem is kellett ilyen de kicsit másképp. Szerintem tudod használni. Ez azt csinálja hogy pl. A oszlop az mindig egy fix szöveg a B oszlopba vannak a vesszővel szeparált szövegek, és a D oszlopba szétszedi őket egymás alá de a fix szöveggel együtt.
Sub vesszovel_szetszedett()
Dim rng As Range, Lstrw As Long, c As Range
Dim SpltRng As Range
Dim i As Integer
Dim Orig As Variant
Dim txt As String
Lstrw = Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Range("A2:A" & Lstrw)
For Each c In rng.Cells
Set SpltRng = c.Offset(, 1)
txt = SpltRng.Value
Orig = Split(txt, ",")
For i = 0 To UBound(Orig)
Cells(Rows.Count, "D").End(xlUp).Offset(1) = c
Cells(Rows.Count, "D").End(xlUp).Offset(, 1) = Orig(i)
Next i
Next c
End Sub
A kód elindítása után így néz ki.
-
lcdtv
tag
Sziasztok!
Milyen megoldás van arra, hogy több ezer soros adatból, pl vonalkód olvasóval beírt adat után megkeresse az egyezőket ugorjon is oda arra a sorra és emelje is ki színnel. Találtam egy vba kódot de az csak megmutatja a sor sorszámát.Sub hanyadiksorbanvan()
Dim Prompt As String
Dim RetValue As String
Dim Rng As Range
Dim RowCrnt As Long
Prompt = ""
With Sheets("Munka1")
Do While True
RetValue = InputBox(Prompt & "Give me a value to look for")
'RetValue will be empty if you click cancel
If RetValue = "" Then
Exit Do
End If
Set Rng = .Columns("A:A").Find(What:=RetValue, After:=.Range("A1"), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Rng Is Nothing Then
Prompt = "I could not find """ & RetValue & """"
Else
RowCrnt = Rng.Row
Prompt = "I found """ & RetValue & """ on row " & RowCrnt
End If
Prompt = Prompt & vbLf
Loop
End With
End Sub -
-
lcdtv
tag
Köszönöm! Mind a kettő megoldás működik igaz Power Query-ben csak egy fület tudok összevonni valamiért.
A javított makród pöpec lett. Esetleg hogy ugyan abban a sorrendben hagyja a füleket mint ahogy van? Valamiért átrendezi visszafelé + egy Munka1 nevűt is létrehoz.
Ez a hiba mit jelent (minden alkalommal hozza)<?xml version="1.0" encoding="UTF-8" standalone="true"?>
-<recoveryLog xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main">
<logFileName>error009600_01.xml</logFileName>
<summary>Hiba a fájlban (D:\Mappa\eredmeny.xlsx)</summary>
-<removedFeatures summary="Az eltávolított funkciók listája:">
<removedFeature>Eltávolított funkció: Adatok érvényesítése innen: /xl/worksheets/sheet2.xml</removedFeature>
<removedFeature>Eltávolított funkció: Adatok érvényesítése innen: /xl/worksheets/sheet3.xml</removedFeature>
<removedFeature>Eltávolított funkció: Adatok érvényesítése innen: /xl/worksheets/sheet5.xml</removedFeature>
<removedFeature>Eltávolított funkció: Adatok érvényesítése innen: /xl/worksheets/sheet6.xml</removedFeature>
<removedFeature>Eltávolított funkció: Adatok érvényesítése innen: /xl/worksheets/sheet7.xml</removedFeature>
<removedFeature>Eltávolított funkció: Adatok érvényesítése innen: /xl/worksheets/sheet8.xml</removedFeature>
<removedFeature>Eltávolított funkció: Adatok érvényesítése innen: /xl/worksheets/sheet9.xml</removedFeature>
<removedFeature>Eltávolított funkció: Adatok érvényesítése innen: /xl/worksheets/sheet10.xml</removedFeature>
</removedFeatures>
</recoveryLog> -
lcdtv
tag
Látom Profi Mutt fórumtárs.
Egyszer már kérdeztem és van is rá megoldás sajna fizetős , de ha nincs más akkor megveszem.
Adott több munkalap azon belül 10 fül természetesen a fülek nevei ugyan azok. Ezeket kellene összevonnom egy munkalappá. Eddig csak egy fül volt, egy adott könyvtárba bemásoltam majd Indit gomb és összevonta az összes munkalapot ami a könyvtárba volt ( de csak az első fület )
ez volt a kód ( ha esetleg ezt át lehetne alakítani hogy minden fület fűzzön össze )Sub ttt()
mappak = Array("D:\Mappa\")
If Dir("D:\Mappa\eredmeny.xlsx") <> "" Then Kill "D:\Mappa\eredmeny.xlsx"
For Each mappa In mappak
Set uj = Workbooks.Add
fajl = Dir(mappa & "*.xlsx")
celsor = 1
Do While fajl <> ""
Workbooks.Open Filename:=mappa & fajl, ReadOnly:=True
sor = Range("a1").SpecialCells(xlLastCell).Row
If celsor = 1 Then
Range("a1", Range("a1").SpecialCells(xlLastCell)).Copy uj.Sheets(1).Cells(celsor, 1)
celsor = celsor + sor
Else
Range("a2", Range("a1").SpecialCells(xlLastCell)).Copy uj.Sheets(1).Cells(celsor, 1)
celsor = celsor + sor - 1
End If
ActiveWorkbook.Close False
fajl = Dir()
Loop
uj.SaveAs mappa & "eredmeny.xlsx"
uj.Close False
Next
MsgBox "Kész"
End Sub -
lcdtv
tag
válasz
Delila_1
#38032
üzenetére
Igen azt néztem de az egymás mellé oszlopokba teszi, nekem meg egymás alá kellene. Találtam egy megoldást lehet másnak is jó lehet
Sub ChickatAH()
Dim rng As Range, Lstrw As Long, c As Range
Dim SpltRng As Range
Dim i As Integer
Dim Orig As Variant
Dim txt As String
Lstrw = Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Range("A2:A" & Lstrw)
For Each c In rng.Cells
Set SpltRng = c.Offset(, 1)
txt = SpltRng.Value
Orig = Split(txt, " ")
For i = 0 To UBound(Orig)
Cells(Rows.Count, "D").End(xlUp).Offset(1) = c
Cells(Rows.Count, "D").End(xlUp).Offset(, 1) = Orig(i)
Next i
Next c
End Sub
csak egy hiányzik hogy külön fülre tegye az eredményt. -
-
lcdtv
tag
Tud valaki arra megoldást, hogy ha A oszlop szövege "Pirosalma: 5 tonna" B oszlop szövege "Érett Pirosalma:" akkor a maradék szöveget az A oszlopból ami "5 tonna" a C oszlopba írja ki. Amit vizsgálni kell az mindig kettősponttal van zárva és utána a szöveg mindig egy szóköz után indul. Előre is köszi!
-
lcdtv
tag
Sziasztok! Szeretnék segítséget kérni.
Van a G oszlop ahol vagy számok vannak vagy 0. Van az A oszlop ahol egy bírt szöveg van. Ez több ezer sorban. Szeretném ha kilistázná külön lapra azokat ahol az érték nem 0. és mellé írná az A oszlop szövegét. Előre is nagyon köszönöm! -
lcdtv
tag
Válaszolok is ha valakinek szüksége lenne rá.
Option Explicit
Public Enum DownloadFileDisposition
OverwriteKill = 0
OverwriteRecycle = 1
DoNotOverwrite = 2
PromptUser = 3
End Enum
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Windows API functions, constants,and types.
' Used for RecycleFile.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function SHFileOperation Lib "shell32.dll" Alias _
"SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Declare Function PathIsNetworkPath Lib "shlwapi.dll" _
Alias "PathIsNetworkPathA" ( _
ByVal pszPath As String) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" _
Alias "GetSystemDirectoryA" ( _
ByVal lpBuffer As String, _
ByVal nSize As Long) As Long
Private Declare Function SHEmptyRecycleBin _
Lib "shell32" Alias "SHEmptyRecycleBinA" _
(ByVal hwnd As Long, _
ByVal pszRootPath As String, _
ByVal dwFlags As Long) As Long
Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_NOCONFIRMATION = &H10
Private Const MAX_PATH As Long = 260
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
'''''''''''''''''''''''''''
' Download API function.
''''''''''''''''''''''''''''''''''''''
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DownloadFile
' This downloads a file from a URL to a local filename.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function DownloadFile(UrlFileName As String, _
DestinationFileName As String, _
Overwrite As DownloadFileDisposition, _
ErrorText As String) As Boolean
Dim Disp As DownloadFileDisposition
Dim Res As VbMsgBoxResult
Dim B As Boolean
Dim S As String
Dim L As Long
ErrorText = vbNullString
If Dir(DestinationFileName, vbNormal) <> vbNullString Then
Select Case Overwrite
Case OverwriteKill
On Error Resume Next
Err.Clear
Kill DestinationFileName
If Err.Number <> 0 Then
ErrorText = "Error Kill'ing file '" & DestinationFileName & "'." & vbCrLf & Err.Description
DownloadFile = False
Exit Function
End If
Case OverwriteRecycle
On Error Resume Next
Err.Clear
B = RecycleFileOrFolder(DestinationFileName)
If B = False Then
ErrorText = "Error Recycle'ing file '" & DestinationFileName & "." & vbCrLf & Err.Description
DownloadFile = False
Exit Function
End If
Case DoNotOverwrite
DownloadFile = False
ErrorText = "File '" & DestinationFileName & "' exists and disposition is set to DoNotOverwrite."
Exit Function
'Case PromptUser
Case Else
S = "The destination file '" & DestinationFileName & "' already exists." & vbCrLf & _
"Do you want to overwrite the existing file?"
Res = MsgBox(S, vbYesNo, "Download File")
If Res = vbNo Then
ErrorText = "User selected not to overwrite existing file."
DownloadFile = False
Exit Function
End If
B = RecycleFileOrFolder(DestinationFileName)
If B = False Then
ErrorText = "Error Recycle'ing file '" & DestinationFileName & "." & vbCrLf & Err.Description
DownloadFile = False
Exit Function
End If
End Select
End If
L = URLDownloadToFile(0&, UrlFileName, DestinationFileName, 0&, 0&)
If L = 0 Then
DownloadFile = True
Else
ErrorText = "Buffer length invalid or not enough memory."
DownloadFile = False
End If
End Function
Private Function RecycleFileOrFolder(FileSpec As String) As Boolean
Dim FileOperation As SHFILEOPSTRUCT
Dim lReturn As Long
If (Dir(FileSpec, vbNormal) = vbNullString) And _
(Dir(FileSpec, vbDirectory) = vbNullString) Then
RecycleFileOrFolder = True
Exit Function
End If
With FileOperation
.wFunc = FO_DELETE
.pFrom = FileSpec
.fFlags = FOF_ALLOWUNDO
' Or
.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
End With
lReturn = SHFileOperation(FileOperation)
If lReturn = 0 Then
RecycleFileOrFolder = True
Else
RecycleFileOrFolder = False
End If
End Function
Sub example()
Dim URL As String
Dim LocalFileName As String
Dim B As Boolean
Dim ErrorText As String
Dim c As Range
For Each c In Columns("K:L").SpecialCells(xlCellTypeConstants, 23)
URL = c
LocalFileName = "C:\temp\" & Evaluate("TRIM(RIGHT(SUBSTITUTE(""" & c & """,""/"",REPT("" "",1000)),1000))")
B = DownloadFile(UrlFileName:=URL, _
DestinationFileName:=LocalFileName, _
Overwrite:=PromptUser, _
ErrorText:=ErrorText)
If B = True Then
Debug.Print "Download successful"
Else
Debug.Print "Download unsuccessful: " & ErrorText
End If
Next c
End Sub
. Nagyon köszönöm!
Új hozzászólás Aktív témák
Hirdetés
- Autós topik
- Milyen billentyűzetet vegyek?
- Milyen belső merevlemezt vegyek?
- Béta iOS-t használók topikja
- Milyen program, ami...?
- AMD Ryzen 9 / 7 / 5 9***(X) "Zen 5" (AM5)
- OFF TOPIC 44 - Te mondd, hogy offtopic, a te hangod mélyebb!
- Anglia - élmények, tapasztalatok
- Milyen légkondit a lakásba?
- Honor Magic5 Pro - kamerák bűvöletében
- További aktív témák...
- Kaspersky, McAfee, Norton, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- Windows 10/11 Home/Pro , Office 2024 kulcsok
- Eladó Steam kulcsok kedvező áron!
- Bontatlan - BATTLEFIELD 1 Collectors Edition - Játékszoftver nélkül
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- Samsung Galaxy Watch Ultra
- Dell USB-C dokkolók: (K20A) WD19/ WD19S/ WD19DC + 130W, 180W, 240W töltők
- Telefon felvásárlás!! iPhone 14/iPhone 14 Plus/iPhone 14 Pro/iPhone 14 Pro Max
- LG 27GR95UM - 27" MiniLED - UHD 4K - 160Hz 1ms - NVIDIA G-Sync - FreeSync Premium PRO - HDR 1000
- BESZÁMÍTÁS! MSI B450 R7 7 5700X 32GB DDR4 512GB SSD RTX 2080 8GB Fractal Design Define R5 FSP 750W
Állásajánlatok
Cég: CAMERA-PRO Hungary Kft
Város: Budapest
Cég: Promenade Publishing House Kft.
Város: Budapest