Блог

Главная - Вопросы по программированию - Поиск уникального значения и вызов sub, если не перейти к следующей ячейке

Поиск уникального значения и вызов sub, если не перейти к следующей ячейке

#excel #vba #loops #unique

Вопрос:

Я пытаюсь создать автоматический вызов для подчиненного на основе уникальных значений.

Столбец 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 (с картинки), он вызывает мой почтовый ящик для PAU21001316 и PAU21001318, но не для PAU21001319 и PAU21001320.

Код должен делать следующее : Если я выберу ячейку, скажем, PAU21001309, чтобы посмотреть, имеет ли ячейка выше ( или ниже) то же значение, если это то же самое, чтобы переместить одну ячейку ниже, если не запускать заказ по электронной почте, а затем перейти к следующей ячейке и сделать то же самое. Затем, если ячейка пуста, остановитесь.

Смысл в том, чтобы запускать каждое уникальное значение одновременно.

Еще одна вещь, которую я пытался сделать (первый код в качестве комментария), состояла в том, чтобы перейти к сегодняшней дате и переместить 4 столбца, которые перейдут к первому номеру заказа. Он перемещает активную ячейку, но после этого ничего не делает, просто зацикливается.

Если кто-нибудь сможет помочь мне закончить мой код, я буду благодарен.

 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 amp; ".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 amp; ", <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" amp; ActiveC amp; ".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") amp; _
                "MicrosoftSignaturesxxx.htm"
                
                signImageFolderName = "xxxfiles"
                completeFolderPath = Environ("appdata") amp; "MicrosoftSignatures" amp; 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 " amp; ActiveC
     .HTMLBody = xOutMsg amp; "<br>" amp; Signature
     .Attachments.Add "C:xxx" amp; ActiveC amp; ".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

Это основной код, составленный из разных кодов. Основная цель состоит в том, чтобы получить значение активной ячейки и заглянуть в папку (я не мог заглянуть в подпапки) с именем файла.pdf и прикрепить его к электронному письму. Другая часть состоит в том, чтобы найти имя поставщика в столбце H и подключить его к другому листу «Электронная почта» для электронной почты поставщика и добавить его в раздел «Кому». Другой код предназначен для подписи и текста письма.

Код работает, но только когда я выбираю конкретную ячейку. Но это будет быстрее, если вы будете выполнять каждое задание в течение дня автоматически.

Ответ №1:

Попробуйте это:

 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 amp; ".pdf") 'find any matches
    If colFiles.Count = 0 Then
        MsgBox "File '" amp; ActiveC amp; ".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") amp; "MicrosoftSignaturesxxx.htm"
    signImageFolderName = "xxxfiles"
    completeFolderPath = Environ("appdata") amp; "MicrosoftSignatures" amp; signImageFolderName
    If Dir(SigString) <> "" Then
        Signature = VBA.Replace(GetBoiler(SigString), signImageFolderName, completeFolderPath)
    End If

    With OutMail
        .To = sRes
        .CC = ""
        .BCC = ""
        .Subject = "xxx " amp; ActiveC
        .HTMLBody = TimeGreeting amp; ", <br> <br> xxx<br/>" amp; 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

Комментарии:

1. Спасибо вам за код. Теперь он начинает зацикливать только один файл и открывать несколько писем с одним и тем же номером. Я уже делал это раньше с циклом и пошел искать другое решение. Я не уверен, что это из моего другого кода, так как он очень грязный, но он работает для одного значения.

2. Я добавил код для писем, так как, возможно, возникнет проблема с циклом. Я получаю ошибку, если нахожусь в случайной ячейке, и код останавливается и помечает «sRes = Приложение». VLookup(b2, rg, 3, Верно)» Если я нахожусь в PO и файл существует в папке, он начинает создавать одно и то же электронное письмо с одним и тем же файлом снова и снова. (не переходя к следующему).

3. В EmailOrder вместо ActiveCell использования c Код ничего не выбирает/не активирует, а передает ячейку для работы напрямую EmailOrder . Это самый надежный способ структурировать ваш код.

4. Спасибо. Ты действительно самый лучший. 🙂 Сейчас все работает. Теперь я собираюсь лучше структурировать свой код, так как знаю, что это настоящий беспорядок и позор для кодеров 🙂

5. Извините за лишний вопрос, но знаете ли вы простой способ поиска во вложенных папках? Я перепробовал несколько кодов, но они были слишком длинными и сложными, и я определенно что-то испортил бы, если бы попытался их реализовать. Что ж, в какой-то момент я попытаюсь, так как люблю находить решения проблем, но если есть простой способ, я был бы благодарен. Мне нужно как-то DirFile = "C:xxx" amp; c amp; ".pdf" это посмотреть во вложенных папках и во вложении. Если нет, то я постараюсь изо всех сил и, возможно, узнаю что-то новое 🙂

Метки: ,