no need!!!!!
Should you need to hire somebody ... there is a dedicated section :
no need!!!!!
Should you need to hire somebody ... there is a dedicated section :
i not a code writer........ i dunno how it write ..................... so nvm thx
Samilar to this code but missing status @ Col C
and it also wont delete empty folder after moved.
Sub Move_Files_To_NewFolder()
'http://www.rondebruin.nl/folder.htm
'This example move all Excel files from FromPath to ToPath.
'Note: It will create the folder ToPath for you
Dim FSO As Object
Dim FromPath As String, ToPath As String
Dim FileExt As String, FNames As String
Dim LR As Long, i As Long
LR = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LR
FromPath = Range("A" & i).Value
ToPath = Range("B" & i).Value
FileExt = "*.*" '<< Change / You can use *.* for all files or *.doc* for word files
If Right(FromPath, 1) <> "\" Then FromPath = FromPath & "\"
FNames = Dir(FromPath & FileExt)
If Len(FNames) = 0 Then MsgBox "No files in " & FromPath
Set FSO = CreateObject("scripting.filesystemobject")
FSO.CreateFolder (ToPath)
FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
Next
End Sub
Display More
Hello,
For a start ... you could take a look at following :
http://%22https//www.ozgrid.co…#post1058164%22
Hope this will help
Hi, i really need some help. I had many folder to move
I want to move ALL FILES inside folder A to folder B base on below table
*No overwrite of file with same filename as whole
*delete empty folder once folder is moved (on col A)
*Create folder (on col B)
[TABLE="border: 1"]
[tr][td]From Folder (Col A)
[/td][td]Move to Folder (Col B)
[/td][td]Status (Col C)
[/td][/tr][tr][td]\\abc\folder1\
[/td][td]\\abc\Main1\
[/td][td]Moved / File existed?
[/td][/tr][tr][td]\\abc\folder2\
[/td][td]\\abc\Main1\
[/td][td]Moved
[/td][/tr][tr][td]\\abc\folder3\
[/td][td]\\abc\Main2\
[/td][td]Moved
[/td][/tr][tr][td]\\abc\folder4\
[/td][td]\\abc\Main2\
[/td][td]Moved
[/td][/tr][tr][td]\\abc\folder5\
[/td][td]\\abc\Main2\
[/td][td]Moved
[/td][/tr]
[/TABLE]
Base on current (below) code.
Possible to add on more function?
Possible to move send email to ARCHIVE Folder once email sent on outlook?
From Inbox 'sent folder' to ARCHIVE
PST Name: SENT_ARCHIVE
Subfolder: SendFolder
Or nt, is there a code where i can put in outlook
Sub SendEmail()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long, d As Long
Dim wks As Worksheet, pf As String, wPath As String, wFile As Variant, wPattern As String
Dim num_err As Variant, sErr As Boolean
'START of confirmation message box'
response = MsgBox("Start sending email?", vbYesNo)
If response = vbNo Then
MsgBox ("Macro Canceled!")
Exit Sub
End If
'END of confirmation message box'
Set Mail_Object = CreateObject("Outlook.Application")
Set wks = Worksheets("SendEmail")
lr = wks.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
sErr = False
With Mail_Object.CreateItem(o)
.to = wks.Range("B" & i).Value
.cc = wks.Range("C" & i).Value
.Subject = wks.Range("D" & i).Value
.Body = wks.Range("E" & i).Value & vbNewLine & _
wks.Range("F" & i).Value & vbNewLine & _
wks.Range("G" & i).Value
pf = wks.Range("H" & i).Value
d = InStrRev(pf, "\")
wPath = Left(pf, d)
wPattern = Mid(pf, d + 1)
If wPath <> "" Then
If wPattern = "" Then wPattern = "*.*"
'If Right(wPath, 1) <> "\" Then wPath = wPath & "\"
If Dir(wPath, vbDirectory) <> "" Then
wFile = Dir(wPath & wPattern)
On Error Resume Next
If wFile <> "" Then
Do While wFile <> ""
.Attachments.Add wPath & wFile
num_error = Err.Number
If num_error <> 0 Then
wks.Range("I" & i).Value = "ERROR Exceed Size"
sErr = True
End If
wFile = Dir()
Loop
Else
wks.Range("I" & i).Value = "ERROR Wrong File URL"
sErr = True
End If
On Error GoTo 0
Else
wks.Range("I" & i).Value = "ERROR Wrong Folder URL"
sErr = True
End If
End If
If sErr = False Then
.Send
'.display 'disable display and enable send to send automatically
num_error = Err.Number
If num_error <> 0 Then
wks.Range("I" & i).Value = Err.Description
Else
wks.Range("I" & i).Value = "Email Send!"
End If
End If
Application.Wait (Now + TimeValue("0:00:07")) 'Pausing an application for 3s, before next email
End With
Next i
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub
Display More
Thanks but i got an error @ Attachments.Add
But again, i got someone to help and manage to get the script work.
Sub SendEmail()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
Dim wks As Worksheet, wPath As String, wFile As Variant
'START of confirmation message box'
response = MsgBox("Start sending email?", vbYesNo)
If response = vbNo Then
MsgBox ("Macro Canceled!")
Exit Sub
End If
'END of confirmation message box'
lr = Cells(Rows.Count, "B").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
Set wks = Worksheets("send_email")
For i = 2 To lr
With Mail_Object.CreateItem(o)
.To = wks.Range("B" & i).Value
.CC = wks.Range("C" & i).Value
.Subject = wks.Range("D" & i).Value
.Body = wks.Range("E" & i).Value
wPath = wks.Range("F" & i).Value
If Right(wPath, 1) <> "\" Then wPath = wPath & "\"
If Dir(wPath, vbDirectory) <> "" Then
wFile = Dir(wPath & "*.*")
Do While wFile <> ""
.Attachments.Add wPath & wFile
wFile = Dir()
Loop
End If
.Send
'.display 'disable display and enable send to send automatically
Application.Wait (Now + TimeValue("0:00:03")) 'Pausing an application for 3s, before next email
End With
Next i
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub
Display More
[TABLE="border: 1"]
[tr]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]C[/TD]
[TD="align: center"]D[/TD]
[TD="align: center"]E[/TD]
[TD="align: center"]F[/TD]
[TD="align: center"]S/N[/TD]
[TD="align: center"]To:[/TD]
[TD="align: center"]cc[/TD]
[TD="align: center"]Subject[/TD]
[TD="align: center"]Body[/TD]
[TD="align: center"]Path of Attachment folder[/TD]
1
[/td][td][/td][td][/td][td]test email 1
[/td][td]Hello Email
[/td][td]C:\Users\ABC\Desktop\SavedFolder\Folder1
[/td][/tr]
[/TABLE]
I had a code below but due i not gd in vba coding, I need some help!
Possible base on below code to addon email Attachment?
The following code work for Col A to E but F i dont know?
Suppose Outlook will attach all files* that found (based on col F Path) and email.
If no folder found or no files in the folder, it will be ignored and send.
Sub SendEmail()
'START of confirmation message box'
response = MsgBox("Start sending email?", vbYesNo)
If response = vbNo Then
MsgBox ("Macro Canceled!")
Exit Sub
End If
'END of confirmation message box'
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
Dim wks As Worksheet
lr = Cells(Rows.Count, "B").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
Set wks = Worksheets("send_email")
For i = 2 To lr
With Mail_Object.CreateItem(o)
.To = wks.Range("B" & i).Value
.CC = wks.Range("C" & i).Value
.Subject = wks.Range("D" & i).Value
.Body = wks.Range("E" & i).Value
.Send
'.display 'disable display and enable send to send automatically
Application.Wait (Now + TimeValue("0:00:03")) 'Pausing an application for 3s, before next email
End With
Next i
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub
Display More
This work but it cant retain the original colour / highlight.
Some data is highlighted for special remark. I hope it can retain the riginal colour / highlight. only shift the position.
Try changing the "CustomSort" code to
Code Display MoreSub CustomSort() Dim x, y(), z(), List, data(), i As Long, ii As Long, iii As Long, ly As Long, lz As Long List = Sheets("customlist").Columns(1).SpecialCells(2) With ActiveSheet.Cells(1).CurrentRegion.Resize(, 50) x = .Value2 For i = 2 To UBound(x, 1) Erase y: ly = 0: lz = 0 For ii = 2 To UBound(x, 2) If x(i, ii) <> "" Then If Not IsError(Application.Match(x(i, ii), List, 0)) Then ly = ly + 1: ReDim Preserve y(1 To ly) y(ly) = Application.Match(x(i, ii), List, 0) Else lz = lz + 1: ReDim Preserve z(1 To lz): z(lz) = x(i, ii) End If x(i, ii) = "" End If Next Call ArraySort(y, 1, ly) If lz = 0 Then ReDim data(1 To ly) For iii = 1 To UBound(data) x(i, iii + 1) = List(y(iii), 1) Next Else Call ArraySort(z, 1, lz) ReDim data(1 To ly) For iii = 1 To UBound(data) x(i, iii + 1) = List(y(iii), 1) Next For iii = 1 To lz ReDim Preserve data(1 To UBound(data) + 1) x(i, UBound(data) + 1) = z(iii) Next End If Next .Value2 = x End With End Sub
Leave the ArraySort code as it is.
ehh.
no. At the data sheet, some number had unique font colour & highlighted to represent something, tht y i cant set it as a whole.
That y the previous script will not change anything and only shift the position.
If you set the required format (font colour etc.) for the whole data area, then the macro will not change that and formatting should be correct after macro run.
hmmm, after i update the customlist with actual entries of (maybe 500).
The error is gone.
But could u fix that? it seen like number found on data which is not found on customlist are not shifted to the last cell? (nt sure but this is what i guess)
With the file I attached or with the code copy/pasted to your actual file?
Hi, I had an error @
it say: Run-time error '9': subscript out of range
when i debug, it show highlight on this line.
pivot = x((inLow + inHi) \ 2)
Try the attached version of your sample file. Note I added 3 values ("Bad1", "Bad2", "Bad3") in order to test values that were not in the "Custom List"
Code assigned to button
Code Display MoreOption Explicit Sub CustomSort() Dim x, y(), z(), List, data(), i As Long, ii As Long, iii As Long, ly As Long, lz As Long List = Sheets("customlist").Columns(1).SpecialCells(2) With ActiveSheet.Cells(1).CurrentRegion.Resize(, 50) x = .Value2 For i = 2 To UBound(x, 1) Erase y: ly = 0: lz = 0 For ii = 2 To UBound(x, 2) If x(i, ii) <> "" Then If Not IsError(Application.Match(x(i, ii), List, 0)) Then ly = ly + 1: ReDim Preserve y(1 To ly) y(ly) = Application.Match(x(i, ii), List, 0) Else lz = lz + 1: ReDim Preserve z(1 To lz): z(lz) = x(i, ii) End If x(i, ii) = "" End If Next Call ArraySort(y, 1, ly) If lz = 0 Then ReDim data(1 To ly) For iii = 1 To UBound(data) x(i, iii + 1) = List(y(iii), 1) Next Else Call ArraySort(z, 1, lz) ReDim data(1 To ly) For iii = 1 To UBound(data) x(i, iii + 1) = List(y(iii), 1) Next For iii = 1 To lz ReDim Preserve data(1 To UBound(data) + 1) x(i, UBound(data)) = z(iii) Next End If Next .Value2 = x End With End Sub Public Sub ArraySort(x, inLow As Long, inHi As Long) Dim pivot, tmpSwap, lLow As Long, lHigh As Long lLow = inLow lHigh = inHi pivot = x((inLow + inHi) \ 2) While (lLow <= lHigh) While (x(lLow) < pivot And lLow < inHi) lLow = lLow + 1 Wend While (pivot < x(lHigh) And lHigh > inLow) lHigh = lHigh - 1 Wend If (lLow <= lHigh) Then tmpSwap = x(lLow) x(lLow) = x(lHigh): x(lHigh) = tmpSwap lLow = lLow + 1: lHigh = lHigh - 1 End If Wend If (inLow < lHigh) Then ArraySort x, inLow, lHigh If (lLow < inHi) Then ArraySort x, lLow, inHi End Sub
Yes. Think there is extra 2.
Should be like this [TABLE="border: 1, cellpadding: 0, cellspacing: 0"]
[tr]
[TD="width: 106"]01019[/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"]6[/TD]
[TD="width: 117"]89e[/TD]
[TD="width: 117"]NR6[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[/TABLE]
Display MoreOne last question.
[tr]
I assume empty cells are to be ignored, so [TABLE="border: 1, cellpadding: 0, cellspacing: 0"][/tr]
[TD="width: 106"]01019[/TD]
[TD="width: 117"]6[/TD]
[TD="width: 117"]89e[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"]NR6[/TD][tr]
[/TABLE]
will sort to [TABLE="border: 1, cellpadding: 0, cellspacing: 0"][/tr]
[TD="width: 106"]01019[/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"]6[/TD]
[TD="width: 117"]89e[/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"]NR6[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[/TABLE]
Is that correct?