Excel vba coding tutorial
http://www.excel-easy.com/vba.html
pdf : http://www.excelvbatutor.com/vba_book/vbabook_ed2.pdf
---------------------------------------------------------------------------------------
File Rename
Sub a()
Dim Source_File As String
Dim Destination_File As String
Dim sPath As String
sPath = " <FolderPath>"
For i = 1 To 2492
Source_File = sPath & Range("A" & CStr(i))
Destination_File = sPath & Range("B" & CStr(i))
FileCopy Source_File, Destination_File
Kill Source_File
Next i
MsgBox "Completed"
End Sub
Note: "FileCopy Source_File, Destination_File" is One method if error use this code "Name Source_File As Destination_File" and hide "Kill Source_File"
---------------------------------------------------------------------------------------
GET File Names Including Sub Folder
Sub file_names_including_sub_folder()
Application.ScreenUpdating = False
Dim fldpath
Dim fld As Object, fil As Object, fso As Object, j As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next
fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
If fldpath = False Then
MsgBox "Folder Not Selected"
Exit Sub
End If
Workbooks.Add
Cells(1, 1).Value = fldpath
Cells(2, 1).Value = "Path"
Cells(2, 2).Value = "Dir"
Cells(2, 3).Value = "Name"
Cells(2, 4).Value = "Size"
Cells(2, 5).Value = "Type"
Cells(2, 6).Value = "Date Created"
Cells(2, 7).Value = "Date Last Access"
Cells(2, 8).Value = "Date Last Modified"
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.getfolder(fldpath)
j = 4
get_sub_foldernames fld
Range("a1").Font.Size = 9
ActiveWindow.DisplayGridlines = False
Range("a3:h" & Range("a4").End(xlDown).Row).Font.Size = 9
Range("a2:h2").Interior.Color = vbCyan
Columns("c:h").AutoFit
Application.ScreenUpdating = True
End Sub
Sub get_sub_foldernames(ByRef prntfld As Object)
Dim subfld As Object, fil As Object, j As Long
For Each fil In prntfld.Files
j = Range("A1").End(xlDown).Row + 1
Cells(j, 1).Value = fil.Path
Cells(j, 2).Value = Left(fil.Path, InStrRev(fil.Path, "\"))
Cells(j, 3).Value = fil.Name
Cells(j, 4).Value = fil.Size
Cells(j, 5).Value = fil.Type
Cells(j, 6).Value = fil.DateCreated
Cells(j, 7).Value = fil.DateLastAccessed
Cells(j, 8).Value = fil.DateLastModified
Next
For Each subfld In prntfld.SubFolders
get_sub_foldernames subfld
Next subfld
End Sub
---------------------------------------------------------------------------------------
How to add an item to a spelling dictionary
Sub SpellingAddToCustomDict()
Dim perr As Word.ProofreadingErrors, rngSave As Word.Range, rngTemp As Word.Range
Dim colErrors As ProofreadingErrors
Dim rngErr As Range
Dim lngErrCount As Long
Set colErrors = ActiveDocument.SpellingErrors
lngErrCount = colErrors.Count
' Store selection position to restore after spell check dialog moves on
For Each rngErr In colErrors
rngErr.SpellingChecked = True
Set rngSave = Selection.Range
' Create a range backwards from the selection start
Set rngTemp = ActiveDocument.Range(Selection.Start, Selection.Start)
rngTemp.MoveStart wdStory, -1
Set perr = rngTemp.SpellingErrors
If perr.Count > 0 Then
'If MsgBox("Add " & perr.Item(perr.Count).Text & " to the Custom Dictionary?", vbQuestion + vbYesNo) = vbYes Then
SendKeys "a{ESC}" ' Ugly! Sends A to spell check dialog then cancels it when it redisplays
perr.Item(perr.Count).CheckSpelling
rngSave.Select
'End If
End If
Next rngErr
Set perr = Nothing
Set rngTemp = Nothing
End Sub
******************************************
Sub get_sub_foldernames(ByRef prntfld As Object)
Dim subfld As Object, fil As Object, j As Long
For Each fil In prntfld.Files
j = Range("A1").End(xlDown).Row + 1
Cells(j, 1).Value = fil.Path
Cells(j, 2).Value = Left(fil.Path, InStrRev(fil.Path, "\"))
Cells(j, 3).Value = fil.Name
Cells(j, 4).Value = fil.Size
Cells(j, 5).Value = fil.Type
Cells(j, 6).Value = fil.DateCreated
Cells(j, 7).Value = fil.DateLastAccessed
Cells(j, 8).Value = fil.DateLastModified
Next
For Each subfld In prntfld.SubFolders
get_sub_foldernames subfld
Next subfld
End Sub
---------------------------------------------------------------------------------------
Spelling errors words copy the other doc file
Sub CopySpellingErrors()
Dim srcDoc As Document, destDoc As Document
Dim errList As ProofreadingErrors
Dim errSingle As Range
Set srcDoc = ActiveDocument
Set destDoc = Documents.Add
Set errList = srcDoc.Range.SpellingErrors
For Each errSingle In errList
destDoc.Range.InsertAfter errSingle.Text & vbCr
Next
End Sub
---------------------------------------------------------------------------------------
Deleting correctly spelled words in a document
Sub Delete_misspelled_words()
Dim errDocument As ProofreadingErrors
Dim errSingle As Range
Set errDocument = ActiveDocument.Range.SpellingErrors
If errDocument.Count = 0 Then
MsgBox "No spelling errors found."
Else
For Each errSingle In errDocument
'Add ¶ to range
errSingle.MoveEnd wdCharacter, 1
errSingle.Delete
Next
End If
End Sub
---------------------------------------------------------------------------------------
Spelling Errors - 1
--------------------------------------------------------------------------------------------------------------
Extract Hyperlink Address
Function getHyberLinks(r As Range)
getHyberLinks = r.Hyperlinks(1).Address
End Function
--------------------------------------------------------------------------------------------------------------
How to download File (image,all format files) from url
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
Sub dlStaplesImages()
Dim rw As Long, lr As Long, ret As Long, sIMGDIR As String, sWAN As String, sLAN As String
' Change URL
sIMGDIR = "F:\Backup\downloadfiles"
If Dir(sIMGDIR, vbDirectory) = "" Then MkDir sIMGDIR
With ActiveSheet '<-set this worksheet reference properly!
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For rw = 1 To lr
sWAN = .Cells(rw, 1).Value2
sLAN = sIMGDIR & Chr(92) & Trim(Right(Replace(sWAN, Chr(47), Space(999)), 999))
Debug.Print sWAN
Debug.Print sLAN
If CBool(Len(Dir(sLAN))) Then
Call DeleteUrlCacheEntry(sLAN)
Kill sLAN
End If
ret = URLDownloadToFile(0&, sWAN, sLAN, BINDF_GETNEWESTVERSION, 0&)
.Cells(rw, 2) = ret
Next rw
End With
End Sub
--------------------------------------------------------------------------------------------------------------
VBA Input box Empty Not close Inputbox
Sub test()
Dim sEndDate As String
sEndDate = InputBox("Enter Date")
If StrPtr(sEndDate) <> 0 Then
If sEndDate = "" Then
test
End If
End If
End Sub
--------------------------------------------------------------------------------------------------------------
http://www.excel-easy.com/vba.html
pdf : http://www.excelvbatutor.com/vba_book/vbabook_ed2.pdf
---------------------------------------------------------------------------------------
File Rename
Sub a()
Dim Source_File As String
Dim Destination_File As String
Dim sPath As String
sPath = " <FolderPath>"
For i = 1 To 2492
Source_File = sPath & Range("A" & CStr(i))
Destination_File = sPath & Range("B" & CStr(i))
FileCopy Source_File, Destination_File
Kill Source_File
Next i
MsgBox "Completed"
End Sub
Note: "FileCopy Source_File, Destination_File" is One method if error use this code "Name Source_File As Destination_File" and hide "Kill Source_File"
GET File Names Including Sub Folder
Sub file_names_including_sub_folder()
Application.ScreenUpdating = False
Dim fldpath
Dim fld As Object, fil As Object, fso As Object, j As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next
fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
If fldpath = False Then
MsgBox "Folder Not Selected"
Exit Sub
End If
Workbooks.Add
Cells(1, 1).Value = fldpath
Cells(2, 1).Value = "Path"
Cells(2, 2).Value = "Dir"
Cells(2, 3).Value = "Name"
Cells(2, 4).Value = "Size"
Cells(2, 5).Value = "Type"
Cells(2, 6).Value = "Date Created"
Cells(2, 7).Value = "Date Last Access"
Cells(2, 8).Value = "Date Last Modified"
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.getfolder(fldpath)
j = 4
get_sub_foldernames fld
Range("a1").Font.Size = 9
ActiveWindow.DisplayGridlines = False
Range("a3:h" & Range("a4").End(xlDown).Row).Font.Size = 9
Range("a2:h2").Interior.Color = vbCyan
Columns("c:h").AutoFit
Application.ScreenUpdating = True
End Sub
Sub get_sub_foldernames(ByRef prntfld As Object)
Dim subfld As Object, fil As Object, j As Long
For Each fil In prntfld.Files
j = Range("A1").End(xlDown).Row + 1
Cells(j, 1).Value = fil.Path
Cells(j, 2).Value = Left(fil.Path, InStrRev(fil.Path, "\"))
Cells(j, 3).Value = fil.Name
Cells(j, 4).Value = fil.Size
Cells(j, 5).Value = fil.Type
Cells(j, 6).Value = fil.DateCreated
Cells(j, 7).Value = fil.DateLastAccessed
Cells(j, 8).Value = fil.DateLastModified
Next
For Each subfld In prntfld.SubFolders
get_sub_foldernames subfld
Next subfld
End Sub
---------------------------------------------------------------------------------------
How to add an item to a spelling dictionary
Sub SpellingAddToCustomDict()
Dim perr As Word.ProofreadingErrors, rngSave As Word.Range, rngTemp As Word.Range
Dim colErrors As ProofreadingErrors
Dim rngErr As Range
Dim lngErrCount As Long
Set colErrors = ActiveDocument.SpellingErrors
lngErrCount = colErrors.Count
' Store selection position to restore after spell check dialog moves on
For Each rngErr In colErrors
rngErr.SpellingChecked = True
Set rngSave = Selection.Range
' Create a range backwards from the selection start
Set rngTemp = ActiveDocument.Range(Selection.Start, Selection.Start)
rngTemp.MoveStart wdStory, -1
Set perr = rngTemp.SpellingErrors
If perr.Count > 0 Then
'If MsgBox("Add " & perr.Item(perr.Count).Text & " to the Custom Dictionary?", vbQuestion + vbYesNo) = vbYes Then
SendKeys "a{ESC}" ' Ugly! Sends A to spell check dialog then cancels it when it redisplays
perr.Item(perr.Count).CheckSpelling
rngSave.Select
'End If
End If
Next rngErr
Set perr = Nothing
Set rngTemp = Nothing
End Sub
******************************************
Sub get_sub_foldernames(ByRef prntfld As Object)
Dim subfld As Object, fil As Object, j As Long
For Each fil In prntfld.Files
j = Range("A1").End(xlDown).Row + 1
Cells(j, 1).Value = fil.Path
Cells(j, 2).Value = Left(fil.Path, InStrRev(fil.Path, "\"))
Cells(j, 3).Value = fil.Name
Cells(j, 4).Value = fil.Size
Cells(j, 5).Value = fil.Type
Cells(j, 6).Value = fil.DateCreated
Cells(j, 7).Value = fil.DateLastAccessed
Cells(j, 8).Value = fil.DateLastModified
Next
For Each subfld In prntfld.SubFolders
get_sub_foldernames subfld
Next subfld
End Sub
---------------------------------------------------------------------------------------
Spelling errors words copy the other doc file
Sub CopySpellingErrors()
Dim srcDoc As Document, destDoc As Document
Dim errList As ProofreadingErrors
Dim errSingle As Range
Set srcDoc = ActiveDocument
Set destDoc = Documents.Add
Set errList = srcDoc.Range.SpellingErrors
For Each errSingle In errList
destDoc.Range.InsertAfter errSingle.Text & vbCr
Next
End Sub
---------------------------------------------------------------------------------------
Deleting correctly spelled words in a document
Sub Delete_misspelled_words()
Dim errDocument As ProofreadingErrors
Dim errSingle As Range
Set errDocument = ActiveDocument.Range.SpellingErrors
If errDocument.Count = 0 Then
MsgBox "No spelling errors found."
Else
For Each errSingle In errDocument
'Add ¶ to range
errSingle.MoveEnd wdCharacter, 1
errSingle.Delete
Next
End If
End Sub
---------------------------------------------------------------------------------------
Spelling Errors - 1
Sub HighlightSpellingErrors2()
Dim colErrors As ProofreadingErrors
Dim rngErr As Range
Dim lngErrCount As Long
Set colErrors = ActiveDocument.SpellingErrors
lngErrCount = colErrors.Count
For Each rngErr In colErrors
rngErr.SpellingChecked = True
Next rngErr
Application.ScreenUpdating = True
Set rngErr = Nothing
Set colErrors = Nothing
End Sub
Dim colErrors As ProofreadingErrors
Dim rngErr As Range
Dim lngErrCount As Long
Set colErrors = ActiveDocument.SpellingErrors
lngErrCount = colErrors.Count
For Each rngErr In colErrors
rngErr.SpellingChecked = True
Next rngErr
Application.ScreenUpdating = True
Set rngErr = Nothing
Set colErrors = Nothing
End Sub
--------------------------------------------------------------------------------------------------------------
Spelling Errors - 2
Sub Auto_Spell()
Dim myDoc As Document
Dim SpellSuggs As SpellingSuggestions
Set myDoc = ActiveDocument
'********* START THE SPELLING CHECK LOOP ********************
Do While myDoc.SpellingErrors.Count >= 1
'Check to make sure there is at least one spelling error.
Set SpellSuggs = GetSpellingSuggestions(myDoc.SpellingErrors(1).Text)
'Get the array of spelling suggestions that Word is offering
'for the first error in the document.
If SpellSuggs.Count >= 1 Then
'If there are any suggestions, then accept the first suggestion.
myDoc.SpellingErrors(1).Text = SpellSuggs(1)
Else
'If there are NO suggestions, then IGNORE the misspelled word.
'Note: without this step, we will be stuck in an endless loop
'that will constantly attempt to get suggestions for this word.
myDoc.SpellingErrors(1).NoProofing = True
End If
Loop
End Sub
Dim myDoc As Document
Dim SpellSuggs As SpellingSuggestions
Set myDoc = ActiveDocument
'********* START THE SPELLING CHECK LOOP ********************
Do While myDoc.SpellingErrors.Count >= 1
'Check to make sure there is at least one spelling error.
Set SpellSuggs = GetSpellingSuggestions(myDoc.SpellingErrors(1).Text)
'Get the array of spelling suggestions that Word is offering
'for the first error in the document.
If SpellSuggs.Count >= 1 Then
'If there are any suggestions, then accept the first suggestion.
myDoc.SpellingErrors(1).Text = SpellSuggs(1)
Else
'If there are NO suggestions, then IGNORE the misspelled word.
'Note: without this step, we will be stuck in an endless loop
'that will constantly attempt to get suggestions for this word.
myDoc.SpellingErrors(1).NoProofing = True
End If
Loop
End Sub
--------------------------------------------------------------------------------------------------------------
Extract Hyperlink Address
Function getHyberLinks(r As Range)
getHyberLinks = r.Hyperlinks(1).Address
End Function
--------------------------------------------------------------------------------------------------------------
How to download File (image,all format files) from url
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
Sub dlStaplesImages()
Dim rw As Long, lr As Long, ret As Long, sIMGDIR As String, sWAN As String, sLAN As String
' Change URL
sIMGDIR = "F:\Backup\downloadfiles"
If Dir(sIMGDIR, vbDirectory) = "" Then MkDir sIMGDIR
With ActiveSheet '<-set this worksheet reference properly!
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For rw = 1 To lr
sWAN = .Cells(rw, 1).Value2
sLAN = sIMGDIR & Chr(92) & Trim(Right(Replace(sWAN, Chr(47), Space(999)), 999))
Debug.Print sWAN
Debug.Print sLAN
If CBool(Len(Dir(sLAN))) Then
Call DeleteUrlCacheEntry(sLAN)
Kill sLAN
End If
ret = URLDownloadToFile(0&, sWAN, sLAN, BINDF_GETNEWESTVERSION, 0&)
.Cells(rw, 2) = ret
Next rw
End With
End Sub
--------------------------------------------------------------------------------------------------------------
VBA Input box Empty Not close Inputbox
Sub test()
Dim sEndDate As String
sEndDate = InputBox("Enter Date")
If StrPtr(sEndDate) <> 0 Then
If sEndDate = "" Then
test
End If
End If
End Sub
--------------------------------------------------------------------------------------------------------------
No comments:
Post a Comment