Question

我生成的代码是为了将Outlook电子邮件发送给逾期发票付款的客户而生成的。

目前，代码从工作簿中的单元格中提取数据 - ＆＃34; WB 1＆＃34; - 我已将每张发票手动输入到电子邮件中。

然后使用SendKeys添加电子邮件签名（我知道此功能不合适，但我遇到了其他解决方法的麻烦）。

代码最终等待5秒（以避免任何影响SendKeys的延迟）并重复在＆＃34; WB 1＆＃34;中选择的任意数量的发票。

我想要做的是能够在代码中加入从＃34; WB 1＆＃34;中获取发票号码的能力。并在我们的发票日志工作簿中搜索相同的值 - ＆＃34; WB 2＆＃34;。

我希望将该发票编号行中大约5个特定列的值复制到＆＃34; WB 1＆＃34;，这意味着我不必手动传输这些值我们发送的每张发票都结束了，这有利于过程的效率。

我尝试过使用Find功能，但不幸的是，由于我在编码和自学成才方面的知识有限，我遇到了一些问题。

如果我的解释令人费解，请告诉我，我们将很乐意进一步讨论。

感谢您的时间。

Sub DunningEmailv2()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeVisible)
    If cell.Value Like "?*@?*.?*" And _
       LCase(Cells(cell.Row, "C").Value) = "yes" Then

        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .SentOnBehalfOfName = "xxx@xxx.xxx"
            .Importance = olImportanceHigh
            .To = cell.Value
            .Subject = "Overdue Invoice Reminder from xxx"
            .Body = "Dear " & Cells(cell.Row, "A").Value & "," _
                  & vbNewLine & vbNewLine & _
                  Cells(cell.Row, "D").Value & " have an outstanding invoice numbered (" & Cells(cell.Row, "E").Value & ")" & ", amounting to $" & Cells(cell.Row, "G").Value & "." _
                  & vbNewLine & vbNewLine & _
                    "This invoice is now " & Cells(cell.Row, "H").Value & " days overdue which has become a concern for us." _
                  & vbNewLine & vbNewLine & _
                    "Please provide confirmation as to when payment will be made." _
                  & vbNewLine & vbNewLine & _
                    "If you have any questions please feel free to ask." _
                  & vbNewLine & vbNewLine & _
                    "Kind regards," _


            '.Attachments.Add ("C:\test.txt")
            .Save
            .Display    


                    Dim currenttime As Date

                    currenttime = Now
                    Do Until currenttime + TimeValue("00:00:05") <= Now
                    Loop


            SendKeys "^+{End}", True
            SendKeys "{End}", True
            SendKeys "%nas~", True

        End With
        On Error GoTo 0
        Set OutMail = Nothing
    End If
Next cell

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

Answer 1

您可以从here

调整此示例

    Sub CopyOpenItems() 
   ' 
   ' CopyOpenItems Macro 
   ' Copy open items to sheet. 
   ' 
   ' Keyboard Shortcut: Ctrl+Shift+O 
   ' 
   Dim wbTarget            As Workbook 'workbook where the data is to be pasted 
   Dim wbThis              As Workbook 'workbook from where the data is to be copied 
   Dim strName             As String   'name of the source sheet/ target workbook 

   'set to the current active workbook (the source book) 
   Set wbThis = ActiveWorkbook 

   'get the active sheetname of the book 
   strName = ActiveSheet.Name 

   'open a workbook that has same name as the sheet name 
   Set wbTarget = Workbooks.Open("C:\filepath\" & strName & ".xlsx") 

   'select cell A1 on the target book 
   wbTarget.Range("A1").Select 

   'clear existing values form target book 
   wbTarget.Range("A1:M51").ClearContents 

   'activate the source book 
   wbThis.Activate 

   'clear any thing on clipboard to maximize available memory 
   Application.CutCopyMode = False 

   'copy the range from source book 
   wbThis.Range("A12:M62").Copy 

   'paste the data on the target book 
   wbTarget.Range("A1").PasteSpecial 

   'clear any thing on clipboard to maximize available memory 
   Application.CutCopyMode = False 

   'save the target book 
   wbTarget.Save 

   'close the workbook 
   wbTarget.Close 

   'activate the source book again 
   wbThis.Activate 

   'clear memory 
   Set wbTarget = Nothing 
   Set wbThis = Nothing 

End Sub

如何从单独的工作簿中的不同特定行中提取值？

1 个答案: