Wednesday, August 26, 2009

Append data from Multiple workbooks without opening the workbooks

Sub Main
Call AppendData
End Sub
 
 
Function GetFolder(ByVal DefaultPath As String)
On Error Resume Next
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
jmp1:
With fd
.InitialFileName = DefaultPath & "\"
.Show
End With
GetFolder = fd.SelectedItems(1)
If GetFolder = Empty Then GoTo errHandler
Exit Function
errHandler:
MsgBox "Please select a folder."
GoTo jmp1

End Function
 

 
Sub AppendData()
Dim folderpath As String
Dim cnt As DAO.Database
Dim rst As DAO.Recordset
Sheets(1).Select
Range("A2").Select
folderpath = GetFolder("C:")
With Application.FileSearch
.NewSearch
.LookIn = folderpath
.SearchSubFolders = False
.Filename = "*.xls"
.Execute
   
    For i = 1 To .FoundFiles.Count
   
        Set cnt = DBEngine.OpenDatabase(.FoundFiles(i), False, False, "Excel 8.0")
        Set rst = cnt.OpenRecordset("Sheet1$")
        ActiveCell.CopyFromRecordset rst
        Cells(Range("E1").End(xlDown).Row + 1, 1).Select
        rst.Close
        cnt.Close
       
    Next
   
   
End With

End Sub
 
For worksheet example check this url http://groups.google.co.in/group/myvbagroup?hl=en
 


See the Web's breaking stories, chosen by people like you. Check out Yahoo! Buzz.

Thursday, August 20, 2009

Conditional Ranking in Excel

Here is the example of Conditional Ranking
 

 

A

B

C

D

E

1 Date Time IN /Out Ranking as per Dates Done
2 2/1/2009 8:50 IN 1 =SUMPRODUCT(($A$2:$A$13=A2)*(B2>$B$2:$B$13))+1
3 2/1/2009 13:10 OUT 2 =SUMPRODUCT(($A$2:$A$13=A3)*(B3>$B$2:$B$13))+1
4 2/1/2009 14:00 IN 3 =SUMPRODUCT(($A$2:$A$13=A4)*(B4>$B$2:$B$13))+1
5 2/2/2009 8:50 IN 1 =SUMPRODUCT(($A$2:$A$13=A5)*(B5>$B$2:$B$13))+1
6 2/2/2009 13:10 OUT 2 =SUMPRODUCT(($A$2:$A$13=A6)*(B6>$B$2:$B$13))+1
7 2/1/2009 23:00 OUT 4 =SUMPRODUCT(($A$2:$A$13=A7)*(B7>$B$2:$B$13))+1
8 2/2/2009 23:00 OUT 4 =SUMPRODUCT(($A$2:$A$13=A8)*(B8>$B$2:$B$13))+1
9 2/3/2009 8:50 IN 1 =SUMPRODUCT(($A$2:$A$13=A9)*(B9>$B$2:$B$13))+1
10 2/3/2009 13:10 OUT 2 =SUMPRODUCT(($A$2:$A$13=A10)*(B10>$B$2:$B$13))+1
11 2/2/2009 14:00 IN 3 =SUMPRODUCT(($A$2:$A$13=A11)*(B11>$B$2:$B$13))+1
12 2/3/2009 23:00 OUT 3 =SUMPRODUCT(($A$2:$A$13=A12)*(B12>$B$2:$B$13))+1
13 2/1/2009 23:50 IN 5 =SUMPRODUCT(($A$2:$A$13=A13)*(B13>$B$2:$B$13))+1



See the Web's breaking stories, chosen by people like you. Check out Yahoo! Buzz.

Wednesday, August 5, 2009

How to create Dynamic validation list in excel

Example:
 
Let say I have two sheets in a workbook
 
1) Lists
2) Answer
 
Sheet Lists :  has two list as follows
 
Sheet "Lists"
 
Sheet "Answer" is as follows
 
 
1) Create Names as follows ( Insert > Names > Define)
 
Name Sheet Name Formula
Type List =OFFSET(List!$A$2,0,0,COUNTA(List!$A:$A)-1,1)
List1 List =List!$B:$B
List2   =OFFSET(List!$C$1,MATCH(Answer!$A33,List1,0)-1,0,COUNTIF(List1,Answer!$A33),1)
 
 
2) Go to Sheet "Answer" select column A and select Data>Validation from Menu.
3) Select List from Allow drop down.
4) and write  =type in Source textbox press OK.
5) Select the column B and Select Data>Validation from Menu.
6) Select List from Allow drop down.
7) and write  =List2 in Source textbox press OK
 
 

Sunday, August 2, 2009

Send mail without using mail clients (Outlook) through VBA


Sub Sendmail()
Set imsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
 
 
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
    .Item("http://schemas.Microsoft.Com/cdo/configuration/smtpusessl") = True
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Range("B4").Value
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = mailid
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = pswd
    .Update
End With
 
strBody = " Attached you will  find your MMO notifications from <our company name here> on ship date: " & Format(Date, "mm/dd/yyyy")
 
With imsg
    Set .Configuration = iConf
    .To = mailid
    .CC = ""
    .BCC = ""
    .From = mailid
    .Subject = "Manual Markout Notification - " & Format(Date, "mm/dd/yyyy")
    .TextBody = strBody
    .AddAttachment (ThisWorkbook.Path & "/" & Replace(Replace(shtData.Range("AC2").Value, ".", ""), "/", "") & " " & Format(Date, "mm-dd-yyyy") & ".mhtml")
    .Send
End With
Set Flds = Nothing
Set imsg = Nothing
Exit Sub
Set Flds = Nothing
Set imsg = Nothing
End Sub


Looking for local information? Find it on Yahoo! Local