Hej!
Koden som ska klippa ut och klistra in en rad där ”Åtgärdat” är valt fungerar inte. Den klistrar inte in ngn rad i blad2.
Hur får man till det?
Private Sub CommandButton1_Click()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Dim Adress As String
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Body content" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2"
On Error Resume Next
If Cells(3, 4) = "Utställningar-Teknik" Then
Adress = "pär.bengtsson"
ElseIf Cells(3, 4) = "Utställningar-Form" Then
Adress = "Sandra.Eyton"
ElseIf Cells(3, 4) = "Fastighet" Then
Adress = "Kenneth.Thilly"
End If
With xOutMail
.To = Adress
.CC = ""
.BCC = ""
.Subject = "Felanmälan GSM"
.Body = "Du har fått en felanmälan: " & Cells(3, 1) & vbNewLine & "Dina tidigare felanmälningar:"
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
With Selection.EntireRow("1:200")
.Cut
.Offset(.Rows.Count + 1).Insert
End With
Dim Home As Worksheet
Set Home = Worksheets("Pågående")
Home.Range("$C$3").Value = Format(Now(), "mm/dd/yyyy")
End Sub
Private Sub worksheet_change(ByVal target As Range)
If Not Intersect(ActiveCell, Range("D4:D100")) Is Nothing Then
Call Changeadress
End If
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Pågående").UsedRange.Rows.Count
J = Worksheets("Blad2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Blad2").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Pågående").Range("E1:E" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
Debug.Print CStr(xRg(K).Value)
If InStr(1, CStr(xRg(K).Value), "Åtgärdat") > 0 Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Blad2").Range("A" & J + 1)
xRg(K).EntireRow.Delete
K = K - 1
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Private Sub Changeadress()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Dim Adress As String
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Body content" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2"
On Error Resume Next
If ActiveCell = "Utställningar-Teknik" Then
Adress = "pär.bengtsson"
ElseIf ActiveCell = "Utställningar-Form" Then
Adress = "Sandra.Eyton"
ElseIf ActiveCell = "Fastighet" Then
Adress = "Kenneth.Thilly"
End If
With xOutMail
.To = Adress
.CC = ""
.BCC = ""
.Subject = "Felanmälan GSM"
.Body = "Du har fått en felanmälan: " & ActiveCell.Offset(0, -3).Text & vbNewLine & "Dina tidigare felanmälningar:"
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
↧