搜索唯一值并调用 sub，如果没有转到下一个单元格 [英] Searching for unique value and call sub, if not go to next cell

问题描述

我正在尝试根据唯一值为子创建自动调用.

I am trying to create automatic call for a sub based on unique values.

E 列订单在E列

Sub FindDate()

Dim Cell As Range


'For Each Cell In ActiveSheet.Range("A1:A50")
'    If Cell.Value = [Today()] Then
'    Cell.Select
'ActiveCell.Offset(0, 4).Select
'    End If
'Exit For
'Next



For Each Cell In ActiveSheet.Range("E2:E100")

If ActiveCell.Value = "" Then


End If
Exit For
Next

For Each Cell In ActiveSheet.Range("E2:E100")
If ActiveCell.Value = ActiveCell.Offset(-1, 0) Then

ActiveCell.Offset(1, 0).Select

        
           Call EmailOrder
    
           ' ElseIf ActiveCell.Value <> ActiveCell.Offset(-1, 0) Then Call EmailOrder
            'ElseIf ActiveCell.Value = "" Then Exit Sub
            End If
        
Next Cell


End Sub

目前使用此代码(我知道它非常混乱，但我只是一个 VBA 初学者)当我选择第二个 PAU21001316(从图片中)然后它调用我的 EmailOrder 子用于 PAU21001316 和 PAU21001318 但不是用于PAU21001319 和 PAU21001320.

At the moment with this code (I know it is a really messy but I am just a VBA beginner) when I select the second PAU21001316 (from the picture) then it is calling my EmailOrder sub for PAU21001316 and PAU21001318 but not for the PAU21001319 and PAU21001320.

代码应该这样做:如果我选择一个单元格，让我们说 PAU21001309 看看上面(或下面)的单元格是否相同，如果不运行则移动一个单元格下面的值相同 Call EmailOrder 和之后移动到下一个单元格并执行相同的操作.然后如果一个单元格为空则停止.

The code should do : If I select a cell, let's say PAU21001309 to look if the cell above ( or below) is the same value, if it's the same to move one cell below if not to run Call EmailOrder and after to move to the next cell and to do the same. Then If a cell is empty to stop.

重点是同时运行每个唯一值.

The point is to run every unique value at the same time.

我想做的另一件事(第一个代码作为注释)是转到今天的日期并移动 4 列，这些列将转到第一个订单号.它正在移动活动单元格，但之后什么都不做，只是循环.

The other thing that I was trying to do (the first code as comment) was to go to the today's date and move 4 columns which will go to the first Order number. It's moving the active cell but after that do nothing, just looping.

如果有人能帮我完成我的代码，我将不胜感激.

If anyone can help me to finish my code I will be grateful.

Sub EmailOrder(c As Range)


    Dim ActiveC As Variant
    Dim DirFile As String
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim strbody As String
    Dim SigString As String
    Dim Signature As String
    Dim xOutMsg As String
    Dim Timenow As String
    
    Dim signImageFolderName As String
    Dim completeFolderPath As String
    
   Dim colFiles As New Collection

'GetFiles "C:\xxx\", ActiveC & ".pdf", True, colFiles
'If colFiles.Count > 0 Then
'    'work with found files
'End If

    
    If Time < TimeValue("12:00:00") Then
Timenow = "Good Morning"
ElseIf Time > TimeValue("12:00:00") And Time < TimeValue("17:00:00") Then
Timenow = "Good Afternoon"
Else
Timenow = "Good Evening"
End If
   
    xOutMsg = Timenow & ", <br> <br> xxx<br/>"


ActiveC = Application.ActiveCell.Value

Dim sRes As String
Dim po As Range
Dim rg As Range
Dim b2 As Range

Set po = ActiveCell.Offset(0, 3)

    
    Set rg = Sheets("Email").Range("B1:D200")
    Set b2 = po
    
    sRes = Application.VLookup(b2, rg, 3, True)


'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.DisplayAlerts = False



DirFile = "C:\xxx\" & ActiveC & ".pdf"
     If Dir(DirFile) = "" Then
  MsgBox "File does not exist", vbCritical
    
  End If
  
  
  Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)


    'Change only Mysig.htm to the name of your signature
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\xxx.htm"
                
                signImageFolderName = "xxxfiles"
                completeFolderPath = Environ("appdata") & "\Microsoft\Signatures\" & signImageFolderName


    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
        
        Signature = VBA.Replace(Signature, signImageFolderName, completeFolderPath)
    Else
        Signature = ""
    End If

'Create Outlook email with attachment
  On Error Resume Next
  
    With OutMail
    
     .To = sRes
     .CC = ""
     .BCC = ""
     .Subject = "xxx " & ActiveC
     .HTMLBody = xOutMsg & "<br>" & Signature
     .Attachments.Add "C:xxx\" & ActiveC & ".pdf"
     .Display
     
    End With
    
    Call FindDate
    
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
   
End Sub

Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
    Dim FSO As Object
    Dim ts As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

这是主要代码，由不同的代码组成.主要目的是获取活动单元格的值并查看文件夹(我无法查看子文件夹)的文件 name.pdf 并将其附加到电子邮件.另一部分是在 H 列中查找供应商名称，然后 VLOOKUP 到另一个工作表电子邮件"中.供应商电子邮件并将其添加到收件人"部分.另一个代码用于电子邮件的签名和正文.

This is the main code, made form different codes. The main purpose is to get the value of the active cell and look in to the folder (I couldn't do to look in to the sub folders) for the file name.pdf and the to attach it to the email. The other part is to look for the supplier name in column H and VLOOKUP to another sheet "Email" for the supplier email and add it to the "To" section. The other code is for the signature and the body of the email.

代码有效，但仅当我选择特定单元格时才有效.但是如果自动完成当天的每个 PO 会更快.

The code is working but only when I select the specific cell. But it will be faster if is doing every PO for the day automatically.

推荐答案

试试这个:

Sub Tester()
    Dim f As Range, c As Range
    
    Set f = Range("A1:A50").Find(Date)  'Look for today's date
    If f Is Nothing Then Exit Sub       'Today not found....
    
    Set c = f.Offset(0, 4) 'move over to Col E
    Do While Len(c.Value) > 0
        If c.Offset(1, 0).Value <> c.Value Then
            EmailOrder c       'pass cell directly to your called sub
        End If
        Set c = c.Offset(1, 0) 'move down one row
    Loop
End Sub

Sub EmailOrder(c As Range)
    Const FLDR As String = "C:\xxx\" 'start search here

    Dim ActiveC As Variant
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim strbody As String
    Dim SigString As String
    Dim Signature As String
    Dim sRes As String
    Dim po
    Dim rg As Range, b2 As Range
    Dim signImageFolderName As String, completeFolderPath As String
    
    Dim colFiles As Collection

    ActiveC = c.Value
    po = c.Offset(0, 3).Value
    Set rg = Sheets("Email").Range("B1:D200")
    
    sRes = Application.VLookup(po, rg, 3, True) 'False?
    
    Set colFiles = GetMatches(FLDR, ActiveC & ".pdf") 'find any matches
    If colFiles.Count = 0 Then
        MsgBox "File '" & ActiveC & ".pdf' does not exist", vbCritical
        Exit Sub
    End If
    'what to do if >1 files found?
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)
    
    'Change only Mysig.htm to the name of your signature
    SigString = Environ("appdata") & "\Microsoft\Signatures\xxx.htm"
    signImageFolderName = "xxxfiles"
    completeFolderPath = Environ("appdata") & "\Microsoft\Signatures\" & signImageFolderName
    If Dir(SigString) <> "" Then
        Signature = VBA.Replace(GetBoiler(SigString), signImageFolderName, completeFolderPath)
    End If

    With OutMail
        .To = sRes
        .CC = ""
        .BCC = ""
        .Subject = "xxx " & ActiveC
        .HTMLBody = TimeGreeting & ", <br> <br> xxx<br/>" & Signature
        .Attachments.Add colFiles(1).Path 'assuming you only want the first match if >1
        .Display
    End With
    
    Call FindDate
    
End Sub

Function TimeGreeting() As String
    If Time < TimeValue("12:00:00") Then
        TimeGreeting = "Good Morning"
    ElseIf Time > TimeValue("12:00:00") And Time < TimeValue("17:00:00") Then
        TimeGreeting = "Good Afternoon"
    Else
        TimeGreeting = "Good Evening"
    End If
End Function

文件搜索功能:

'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr
    Dim colFiles As New Collection
    Dim colSub As New Collection
    
    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder '<< start with the top-level folder
    
    Do While colSub.Count > 0
        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1  '<< remove from queue
        For Each f In fldr.Files 'check all files
            If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
        Next f
        If subFolders Then 'add subfolders to queue for listing
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
    Loop
    Set GetMatches = colFiles
End Function

这篇关于搜索唯一值并调用 sub，如果没有转到下一个单元格的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！