Sub Export()
Dim wdApp As Object
Dim wdDoc As Object
Dim wdRng As Object
Dim exlRng As Range
Dim evalMatrix As Object
Set wdApp = CreateObject("Word.Application")
Set wdDoc = wdApp.Documents.Add
Set exlRng = ActiveSheet.Range(ActiveSheet.Cells(firstRow() - 3, 2), ActiveSheet.Cells(lastRow() + 1, lastColumn))
Set wdRng = wdDoc.Paragraphs(wdDoc.Paragraphs.Count - 2).Range
exlRng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
wdRng.Paste
Set evalMatrix = wdDoc.InlineShapes(1).ConvertToShape
evalMatrix.IncrementRotation -90
End SubSub GenerateEmail()
Dim sEmailBodyp1 As String
Dim sEmailBodyp2 As String
Dim sEmailSubject As String
Dim sEmailTo As String
Dim OutApp As Object
Dim OutMail As Object
Dim UsedRange As Range
sEmailSubject = ActiveSheet.Range("O2").Value
sEmailBodyp1 = ActiveSheet.Range("B2:K20").Select
Selection.Copy
sEmailBodyp2 = ActiveSheet.Range("P2").Value
sEmailTo = ActiveSheet.Range("N2:N15").Value
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = sEmailTo
.Subject = sEmailSubject
.Body = "Good Morning " + vbCrLf + vbCrLf + sEmailBodyp1 + vbCrLf + vbCrLf + sEmailBodyp2
.Display
End With
Set OutMail = Nothing
Next
Set OutApp = Nothing
End SubSub HiddenCopy()
Dim sh As Integer
Dim rw As Integer
sh = 2
rw = 3
' Using this just to test variables ...
Dim x, y, z As String
x = Worksheets(sh).Cells(rw, 5)
y = Worksheets(sh).Cells(rw, 6)
z = Worksheets(sh).Cells(rw, 7)
Debug.Print x & vbCr & y & vbCr & z
' Using "Defined range" it's working ...
'ThisWorkbook.Sheets(2).Range("E3:G3").Copy
'ActiveCell.PasteSpecial xlPasteValues
' Using variables it's not working ... Run-Time Error 1004
ThisWorkbook.Sheets(sh).Range(Cells(rw, 5), Cells(rw, 7)).Copy
ActiveCell.PasteSpecial xlPasteValues
End Sub Sub Email_Reports()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
ztext = [bodytext] 'read in text from named cell
Zsubject = [subjectText]
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'We add a temporary Window to avoid the Copy problem
'if there is a List or Table in one of the sheets and
'if the sheets are grouped
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
'.Sheets("Sales1").Copy
End With
'Close temporary Window
TempWindow.Close
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheets to values if you want
' For Each sh In Destwb.Worksheets
' sh.Select
' With sh.UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
' Destwb.Worksheets(1).Select
' Next sh
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
' TempFileName = Range("B1") & Format(Now, "dd-mmm-yy h-mm-ss")
TempFileName = Format(Range("B1"), "mmm-yy ") & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = Join(Application.Transpose(Range("F1:F4").Value), ";")
.CC = ""
.BCC = ""
.Subject = Zsubject
.Body = ztext
'.Body = strBody
..Attachments.Add ("C:\my documents")
'You can add other files also like this
.display 'Use .send to send automatically or .Display to check email before sending
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Subws.range("D7:D20").value = combobox2.listFunction Submit_AuditSheet_Data()
Dim ws_to As Worksheet
Dim ws_from As Worksheet
Set ws_from = ActiveSheet
Set ws_to = Sheets("Audit_Summary_Sheet")
lrow = ws_to.Cells(Rows.Count, "A").End(xlUp).Row
' finds that last used row in column "A"
ws_to.Range("A" & lrow + 1).Value = ws_from.Range("C5").Value
ws_to.Range("B" & lrow + 1).Value = ws_from.Range("J5").Value
ws_to.Range("C" & lrow + 1).Value = ws_from.Range("J6").Value
ws_to.Range("D" & lrow + 1).Value = ws_from.Range("C12").Value
ws_to.Range("E" & lrow + 1).Value = ws_from.Range("J12").Value
ws_to.Range("F" & lrow + 1).Value = ws_from.Range("J7").Value
ws_to.Range("G" & lrow + 1).Value = ws_from.Range("C8").Value
ws_to.Range("H" & lrow + 1).Value = ws_from.Range("E7").Value
ws_to.Range("I" & lrow + 1).Value = ws_from.Range("D84").Value
ws_to.Range("J" & lrow + 1).Value = ws_from.Range("D91").Value
ws_to.Range("K" & lrow + 1).Value = ws_from.Range("E90").Value
ws_to.Range("L" & lrow + 1).Value = ws_from.Range("K99").Value
ws_to.Range("M" & lrow + 1).Value = ws_from.Range("K100").Value
ws_to.Range("N" & lrow + 1).Value = ws_from.Range("K101").Value
ws_to.Range("O" & lrow + 1).Value = ws_from.Range("K102").Value
ws_to.Range("P" & lrow + 1).Value = ws_from.Range("K103").Value
ws_to.Range("Q" & lrow + 1).Value = ws_from.Range("K104").Value
ws_to.Range("R" & lrow + 1).Value = ws_from.Range("K105").Value
ws_to.Range("S" & lrow + 1).Value = ws_from.Range("K106").Value
ws_to.Range("T" & lrow + 1).Value = ws_from.Range("K107").Value
ws_to.Range("U" & lrow + 1).Value = ws_from.Range("K108").Value
Set ws_from = ActiveSheet
Set ws_to = Sheets("Findings_Summary_Sheet")
lrow = ws_to.Cells(Rows.Count, "A").End(xlUp).Row
' finds that last used row in column "A"
ws_to.Range("D" & lrow + 1).Value = ws_from.Range("O26").Value
End FunctionSub AddDate()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lastRow As Long, x As Long, dif As Long, ws As Worksheet
For Each ws In Sheets(Array("EU", "EA", "UK", "BE", "DK", "DE", "EL", "ES", "FR", "IT", "NL", "AT", "PT", "FI", "SE"))
MsgBox ws.Name
lastRow = ws.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If Year(ws.Range("A" & lastRow).Value) = Year(Date) And Month(ws.Range("A" & lastRow).Value) < Month(Date) Then
dif = Month(Date) - Month(ws.Range("A" & lastRow).Value)
For x = 1 To dif
ws.Cells(lastRow + x, 1).Value = DateAdd("m", x, ws.Cells(lastRow, 1).Value)
Next x
ws.Range("B" & lastRow & ":G" & lastRow).AutoFill Destination:=ws.Range("B" & lastRow).Resize(dif + 1, 6)
ElseIf Year(ws.Range("A" & lastRow).Value) < Year(Date) Then
dif = 12 - Month(ws.Range("A" & lastRow).Value) + Month(Date)
For x = 1 To dif
ws.Cells(lastRow + x, 1).Value = DateAdd("m", x, ws.Cells(lastRow, 1).Value)
Next x
ws.Range("B" & lastRow & ":G" & lastRow).AutoFill Destination:=ws.Range("B" & lastRow).Resize(dif + 1, 6)
End If
Next ws
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End SubSub extend_all_tab_dates_across_on_my_non_manu_charts()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lastRow As Long, x As Long, dif As Long, ws As Worksheet
For Each ws In Sheets(Array("My charts - NON-Manu data"))
' MsgBox ws.Name
lastColumn = ws.Range("B:Z").Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
MsgBox lastColumn
' ^^ already changed from .Row to .Column
'Can't get this below working, although the code detects the last 'empty' cell so far
If Year(ws.Range("B" & lastColumn).Value) = Year(Date) And Month(ws.Range("B" & lastColumn).Value) < Month(Date) Then
dif = Month(Date) - Month(ws.Range("B" & lastColumn).Value)
For x = 6 To dif
ws.Cells(lastColumn + x, 2).Value = DateAdd("m", x, ws.Cells(lastColumn, 1).Value)
Next x
ws.Range("B" & lastColumn & ":X" & lastColumn).AutoFill Destination:=ws.Range("C" & lastColumn).Resize(dif + 1, 2)
ElseIf Year(ws.Range("B" & lastColumn).Value) < Year(Date) Then
dif = 12 - Month(ws.Range("B" & lastColumn).Value) + Month(Date)
For x = 1 To dif
ws.Cells(lastColumn + x, 2).Value = DateAdd("m", x, ws.Cells(lastColumn, 1).Value)
Next x
ws.Range("B" & lastColumn & ":X" & lastColumn).AutoFill Destination:=ws.Range("B" & lastColumn).Resize(dif + 1,)
End If
Next ws
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub