VBA copy and paste data next blank row of a different worksheet each time macro runs

[Cozza22]

Hello everyone, I am not an expert and need help please!

I have a macro button [Get Outlook Data] on a worksheet that when clicked allows you to choose the folder in Outlook and then the data is shown on my worksheet 'Outlook Results'. Each time the macro runs it clears the previous data from worksheet 'Outlook Results', that is required.

The problem is the data needs to be copied to a worksheet 'Results History' and to the next blank line every time data is generated via [Get Outlook Data] button. Not been able to figure this out after several attempts. I have shown the code just before and after where it clears the contents.

Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long ' counter for attachments
Dim debugMsg As Integer

' select output results worksheet and clear previous results
Sheets("Outlook Results").Select
Sheets("Outlook Results").Cells.ClearContents
Range("A1").Select

Set objOutlook = CreateObject("Outlook.Application")
'MsgBox objOutlook, vbOKOnly 'for debugging
Set objNamespace = objOutlook.GetNamespace("MAPI")

Many thanks

 

[Cozza22]

This is the full code, thanks.

Sub GetMailInfo()

Dim results() As String

  ' get contacts
  results = ExportEmails(True)

  ' paste onto worksheet
  Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results

    MsgBox "Completed"
End Sub

Function ExportEmails(Optional headerRow As Boolean = False) As String()

Dim objOutlook As Object ' Outlook.Application
Dim objNamespace As Object ' Outlook.Namespace
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object ' Outlook.items
Dim folderItem As Object
Dim msg As Object ' Outlook.MailItem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long ' counter for attachments
Dim debugMsg As Integer

' select output results worksheet and clear previous results
Sheets("Outlook Results").Select
Sheets("Outlook Results").Cells.ClearContents
Range("A1").Select

Set objOutlook = CreateObject("Outlook.Application")
'MsgBox objOutlook, vbOKOnly 'for debugging
Set objNamespace = objOutlook.GetNamespace("MAPI")
'MsgBox objNamespace, vbOKOnly 'for debugging
'Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
'MsgBox objInbox, vbOKOnly 'for debugging
Set strFolderName = objNamespace.PickFolder
Set mailFolderItems = strFolderName.Items

  ' if calling procedure wants header row
  If headerRow Then
    startRow = 1
  Else
    startRow = 0
  End If

  numRows = mailFolderItems.Count

  ' resize array
  ReDim tempString(1 To (numRows + startRow), 1 To 100)

  ' loop through folder items
  For i = 1 To numRows
    Set folderItem = mailFolderItems.Item(i)

    If IsMail(folderItem) Then
      Set msg = folderItem
    End If

    With msg
      tempString(i + startRow, 1) = .SenderEmailAddress
      tempString(i + startRow, 2) = .cc
      tempString(i + startRow, 3) = .ReceivedTime
      tempString(i + startRow, 4) = .Body
      tempString(i + startRow, 5) = .BodyFormat
      tempString(i + startRow, 6) = .Subject
      tempString(i + startRow, 7) = .Attachments.Count

    End With

    ' adding file attachment names where they exist - added by JP
    If msg.Attachments.Count > 0 Then

        For jAttach = 1 To msg.Attachments.Count
            tempString(i + startRow, 7 + jAttach) = msg.Attachments.Item(jAttach).DisplayName
        Next jAttach

    End If

  Next i

  ' first row of array should be header values
  If headerRow Then

    tempString(1, 1) = "SenderEmailAddress"
    tempString(1, 2) = "cc"
    tempString(1, 3) = "ReceivedTime"
    tempString(1, 4) = "Body"
    tempString(1, 5) = "BodyFormat"
    tempString(1, 6) = "Subject"
    tempString(1, 7) = "Number of Attachments"
    tempString(1, 8) = "Attachment 1 Filename"
    tempString(1, 9) = "Attachment 2 Filename"
    tempString(1, 10) = "Attachment 3 Filename"
    tempString(1, 11) = "Attachment 4 Filename"
    
    
  End If

  ExportEmails = tempString

  ' apply pane freeze and filtering

    Range("A2").Select
    ActiveWindow.FreezePanes = True
    Rows("1:1").Select
    'Selection.AutoFilter

End Function

Function IsMail(itm As Object) As Boolean
  IsMail = (TypeName(itm) = "MailItem")
End Function

 

[Cozza22]

Forgot to close as figured this out a while ago.