Below is my attempt at adding yes/no options to my objshell.popup, getting a type mismatch error, probably doing something wrong...
got it from this website: http://www.informit.com/articles/article.aspx?p=1170490&seqNum=5
Public Sub ShowTable()
Dim myData
Dim myStr As String
Dim x As Integer
Dim myRange As Range
Dim lastrow As Long
Dim nsecond As Long
Dim ws As Worksheet
Call reviewME
UserForm1.Show
Set ws = Worksheets("New Lookups")
lastrow = ws.Cells(Rows.Count, 262).End(xlUp).Row
Set myRange = ws.Range(ws.Cells(2, 262), ws.Cells(lastrow, 262))
myData = myRange.Value
For x = 1 To UBound(myData, 1)
myStr = myStr & myData(x, 1) & vbTab & vbCrLf
Next x
'myStr = myStr & vbNewLine & "Proceed with change requests?"
inttype = vbYesNo + vbQuestion + vbDefaultButton2
Set objshell = CreateObject("Wscript.Shell")
strtitle = "Review your entries"
nsecond = 1
intresult = objshell.popup(myStr, nsecond, strtitle, inttype)
Select Case intresult
Case vbYes
MsgBox "hi"
Case vbNo
MsgBox "no"
End Select
It's because the signature for the Popup method is actually:
WshShell.Popup(strText, [nSecondsToWait], [strTitle], [intType])
and you are forgetting the nSecondsToWait parameter.
nSecondsToWait may be an optional param (as indicated by the brackets around the param name) but if you aren't going to include it then you need to leave an empty slot for it:
intresult = objshell.popup(myStr, , strtitle, inttype)
The type mismatch error is because the second param should be an integer (nSecondsToWait) but you are giving it a string ("Review your entries").
Related
Here is what I have been given to try and create:
User creates an email a few times per week and has to re-type everything, a request for employee updates, with up to 5 people on it. Easy enough to create in VBA, except that the employees could change each time. So there could be just 1 person, or 2, or 3, etc...and each time it could be a different mix of the employees. They want input boxes that would prompt how many employees for the email, then based on that input, follow-up boxes (if more than 1) that allow the input of the names (1 per box). It then needs to create the email, placing the input box data into the body text. Each email text will be based on the input from the 1st input box, so it can adjust for the number of employees (so there could be up to 5 employees on each email).
How do I assign values to my variables (findstrs and foundcells)so that they will adjust to the inputs of the inputboxes without writing all the IF stmts?
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim strbox As String
Dim stritem As String
Dim X As Long
Dim r As Long
Dim LR, lookrng As Range
Dim findStr As String
Dim nameCol As Range
Dim nameCol1 As Range
Dim nameCol2 As Range
Dim nameCol3 As Range
Dim nameCol4 As Range
Dim foundCell As Variant
Dim foundCell1 As Variant
Dim foundcell2 As Variant
Dim strname As String
Dim strBody As String
Dim sigString As String
Dim signature As String
Dim findstr1 As String
Dim foundrng As Range
Dim valuefound As Boolean
Dim strFilename As String
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.CurrentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Set oReply = oMail.ReplyAll
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.CurrentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
Set aOutlook = CreateObject("Outlook.Application")
Set oReply = aOutlook.CreateItem(0)
'Input box(es)
findStr = InputBox("Enter Number of Employees")
findstr1 = InputBox("Enter Name of First Employee")
If findStr = "2" Then findstr2 = InputBox("Enter Name of Second Employee")
If findstr1 = "T1" Then foundCell1 = "<B>Test 1 ID#0000</B>"
If findstr1 = "T2" Then foundcell2 = "<B>Test 2 IDO#0001</B>"
If findstr1 = "T3" Then foundcell3 = "<B>Test 3 ID#0002</B>"
If findstr1 = "T4" Then foundCell4 = "<B>Test 4 ID#0003</B>"
If findstr1 = "T5" Then foundCell5 = "<B>Test 5 ID#0004</B>"
If findstr2 = "T1" Then foundCell1 = "<B>Test 1 ID#0000</B>"
If findstr2 = "T2" Then foundcell2 = "<B>Test 2 IDO#0001</B>"
If findstr2 = "T3" Then foundcell3 = "<B>Test 3 ID#0002</B>"
If findstr2 = "T4" Then foundCell4 = "<B>Test 4 ID#0003</B>"
If findstr2 = "T5" Then foundCell5 = "<B>Test 5 ID#0004</B>"
'Greeting based on time of day
Select Case Time
Case 0.25 To 0.5
GreetTime = "Good morning"
Case 0.5 To 0.71
GreetTime = "Good afternoon"
Case Else
GreetTime = "Good evening"
End Select
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Update.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
If findStr = "1" Then
strBody = "<Font Face=calibri>Can you please update the following: <br><br>" & _
"<B>" & foundCell1 & "</B><br><br>" & _
"Please update this batch. " & _
"I Appreciate your help. Let me know if you need anything.<br><br>" & _
"Thanks <br><br>" & _
subject = "Employee Update"
ElseIf findStr = "2" Then
strBody = "<Font Face=calibri>Can you please add changes for the following: " & _
"<ol><li><B>" & foundCell1 & "</B><br><br><br><br>" & _
"<li><B>" & foundcell2 & "</B><br><br>" & _
subject = "Multiple Employee Requests"
End If
'Sets up the email itself and then displays for review before sending
With oReply
.HTMLBody = "<Font Face=calibri>Hi there,<br><br>" & strBody & signature
.To = "superman#krypton.com"
.CC = "trobbins#shawshank.com "
.subject = "Multiple Employee Updates"
.Importance = 2
.Display
End With
End Sub
You need to break this code down into multiple, smaller and parameterized scopes.
Make a Function that returns the body of the email given a Collection of batch numbers.
Private Function GetEmailBody(ByVal batchNumbers As Collection) As String
Now, the calling code needs to know how many employees there are. Make a function for that.
Private Function GetNumberOfEmployees() As Long
Dim rawInput As Variant
rawInput = InputBox("Number of employees?")
If StrPtr(rawInput) = 0 Then
'user cancelled out of the prompt
GetNumberOfEmployees = -1
Exit Function
Else If IsNumeric(rawInput) Then
GetNumberOfEmployees = CLng(rawInput)
End If
End Function
That'll return -1 if user cancels the prompt, 0 for an invalid input, and the number of employees otherwise.
Dim employeeName As String
Dim nbEmployees As Long
nbEmployees = GetNumberOfEmployees
If nbEmployees = -1 Then
Exit Sub 'bail out
Else If nbEmployees = 0 Then
'reprompt?
Exit Sub 'bail out, cancelled
End If
'fun part here
Dim emailbody As String
emailBody = GetEmailBody(batchNumbers, employeeName)
And now the fun part: you need to add as many items to some batchNumbers collection, as you have nbEmployees. Because you know how many iterations you'll need before you start looping, a For loop will do.
Dim batchNumbers As Collection
Set batchNumbers = New Collection
Dim batchNumber As String
Dim i As Long
For i = 1 To nbEmployees
batchNumber = GetBatchNumber(i)
If batchNumber = vbNullString Then Exit Sub 'bail out:cancelled/invalid
batchNumbers.Add batchNumber
Next
Dim body As String
body = GetEmailBody(batchNumbers)
Where GetBatchNumber(i) is yet another function call, to a function whose role it is to prompt for an employee number and lookup & return the corresponding batch number, returning an empty string if prompt is cancelled or no match is found.
Private Function GetBatchNumber(ByVal index As Long) As String
Dim rawInput As Variant
rawInput = InputBox("Name of employe " & index & ":")
If StrPtr(rawInput) = 0 Then
'cancelled
Exit Function
Else
Dim employeeName as String
employeeName = CStr(rawInput)
GetBatchNumber = GetBatchForEmployee(employeeName)
End If
End Function
If the mappings really actually look like T1 -> <B>Test 1 ID#000</B> then you can probably use this:
Private Function GetBatchForEmployee(ByVal employeeName As String)
Dim digit As Long
digit = CLng(Right$(employeeName, 1))
GetBatchForEmployee = "<B>Test " & digit & " ID#" & Format$(digit - 1, "000") & "</B>"
End Function
If your mappings are actual mappings then you can have a Dictionary lookup in here, or look them up on an Excel worksheet, a CSV or XML data file, a SQL Server database, whatever.
But first, break things down. A procedure that starts like this:
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim strbox As String
Dim stritem As String
Dim X As Long
Dim r As Long
Dim LR, lookrng As Range
Dim findStr As String
Dim nameCol As Range
Dim nameCol1 As Range
Dim nameCol2 As Range
Dim nameCol3 As Range
Dim nameCol4 As Range
Dim foundCell As Variant
Dim foundCell1 As Variant
Dim foundcell2 As Variant
Dim strname As String
Dim strBody As String
Dim sigString As String
Dim signature As String
Dim findstr1 As String
Dim foundrng As Range
Dim valuefound As Boolean
Dim strFilename As String
...is a procedure that's doing way too many things.
I have below code which prints text from a column but open a text file many times instead of once. Please let me know what is the wrong.
When I run sub in Visual Basic debug mode, it open text file only once. But I am calling this macro after another macro and that time it is opening (same) text file many times.
Sub createdevtest()
Dim filename As String, lineText As String
Dim data As Range
Dim myrng As Range, i, j
' filename = ThisWorkbook.Path & "\textfile-" & Format(Now, "ddmmyy-hhmmss") & ".txt"
filename = ThisWorkbook.Path & "\devtest" & ".txt"
Open filename For Output As #1
Dim LastRow As Long
'Find the last non-blank cell in column A(1)
LastRow = Cells(Rows.count, 1).End(xlUp).Row
Range("B4:B" & LastRow).Select
Set myrng = Selection
For i = 1 To myrng.Rows.count
For j = 1 To myrng.Columns.count
lineText = IIf(j = 1, "", lineText & ",") & myrng.Cells(i, j)
Next j
Print #1, lineText
Next i
Close #1
Range("B4").Select
' open devtest
'Shell "explorer.exe" & " " & ThisWorkbook.Path, vbNormalFocus
filename = Shell("Notepad.exe " & filename, vbNormalFocus)
End Sub
Thanks #Luuklag. I had tried to figure out on my own but no success. After your comment, just went thru code again and got clue.
Below is the correct code where I have called one of the macro (devtest1) which contains above text file creation macro (createdevtest). Before correction I was calling macro in function instead of Sub, so it was looping again and opening txt file many times.
' macro to select folder and list files
Sub GetFileNames_devtest()
Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
If Folder.Show <> -1 Then Exit Sub
xDir = Folder.SelectedItems(1)
Call ListFilesInFolder(xDir, True)
' call devtest: corrected to call macro at right place
devtest1
End Sub
Sub ListFilesInFolder(ByVal xFolderName As String, ByVal xIsSubfolders As Boolean)
Dim xFileSystemObject As Object
Dim xFolder As Object
Dim xSubFolder As Object
Dim xFile As Object
Dim rowIndex As Long
Set xFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFileSystemObject.GetFolder(xFolderName)
rowIndex = Application.ActiveSheet.Range("A65536").End(xlUp).Row + 1
For Each xFile In xFolder.Files
Application.ActiveSheet.Cells(rowIndex, 1).Formula = xFile.Name
rowIndex = rowIndex + 1
Next xFile
If xIsSubfolders Then
For Each xSubFolder In xFolder.SubFolders
ListFilesInFolder xSubFolder.Path, True
Next xSubFolder
End If
Set xFile = Nothing
Set xFolder = Nothing
Set xFileSystemObject = Nothing
'' Was calling wrongly macro here
End Sub
Function GetFileOwner(ByVal xPath As String, ByVal xName As String)
Dim xFolder As Object
Dim xFolderItem As Object
Dim xShell As Object
xName = StrConv(xName, vbUnicode)
xPath = StrConv(xPath, vbUnicode)
Set xShell = CreateObject("Shell.Application")
Set xFolder = xShell.Namespace(StrConv(xPath, vbFromUnicode))
If Not xFolder Is Nothing Then
Set xFolderItem = xFolder.ParseName(StrConv(xName, vbFromUnicode))
End If
If Not xFolderItem Is Nothing Then
GetFileOwner = xFolder.GetDetailsOf(xFolderItem, 8)
Else
GetFileOwner = ""
End If
Set xShell = Nothing
Set xFolder = Nothing
Set xFolderItem = Nothing
End Function
End Function
I have a workbook which creates Word reports based on a Word template and tables in the workbook.
Depending on the equipment type, it copies a range from the spreadsheet and pastes it to two bookmark locations in the word document (bmInternal and bmExternal). I tried using PasteAppendTable, but this only works once. If I try to use it twice, for each bookmark, it copies nothing both times. As such I used Paste for one and PasteAppendTable for the second (PasteAppendTable is much neater as the formatting is better).
This worked fine, but I made changes to the code, not related to this, and now the Paste (which goes to bmInternal) isn't working. I can't see why when I've not changed anything regarding that part:
Sub Data2Word()
Application.GoTo Reference:=ActiveSheet.Range("A2")
GoAgain:
On Error Resume Next
Dim vItem As String
'Dim vImagePath As String
Dim vCurrentRow As Integer
Dim vDesc As String
Dim vN2 As String
Dim vGuide As String
Dim vUnit As String
Dim vBlock As String
Dim wrdPic As Word.InlineShape
Dim rng As Excel.Range 'our source range
Dim rngText As Variant
Dim rngText2 As Variant
Dim wdApp As New Word.Application 'a new instance of Word
Dim wdDoc As Word.Document 'our new Word template
Dim myWordFile As String 'path to Word template
Dim wsExcel As Worksheet
Dim tmpAut
'Find Item and type
vItem = ActiveCell.Value
vDesc = ActiveCell.Offset(0, 2)
vN2 = ActiveCell.Offset(0, 1)
vGuide = ActiveCell.Offset(0, 3)
vBlock = ActiveCell.Offset(0, 4)
vUnit = Left(vItem, 3)
If ActiveSheet.Range("rngREPORTED") = "Yes" Then
MsgBox vItem & " already has a report."
Exit Sub
End If
'initialize the Word template path
'here, it's set to be in the same directory as our source workbook
myWordFile = "W:\Entity\Inspect\WORD\INSPECTION TEMPLATES\Inspection Template - 20160511.dotx"
'open a new word document from the template
Set wdDoc = wdApp.Documents.Add(myWordFile)
If vGuide = "IGE01" Then
rngText = "rngEXCH"
rngText2 = "rngEXCHE"
ElseIf ActiveCell.Offset(, 4) = "Mono" Then
'Do Mono
rngText = "rngMONO"
Else
ActiveWorkbook.Names.Add Name:="rngItemSub", RefersTo:=Worksheets("SubEquipment").Range("B" & ActiveCell.Offset(0, 6) & ":C" & ActiveCell.Offset(0, 7) + ActiveCell.Offset(0, 6))
CarryOn:
rngText = "rngItemSub"
End If
'Insert Tables
'get the range of the data
Set rng = Range(rngText)
rng.Copy 'copy the range
wdDoc.Bookmarks("bmInternal").Range.Paste 'AppendTable
If vGuide = "IGE01" Then
Set rng = Range(rngText2)
rng.Copy
End If
wdDoc.Bookmarks("bmExternal").Range.PasteAppendTable
wdDoc.Bookmarks("bmItem").Range.InsertAfter vItem
wdDoc.Bookmarks("bmDesc").Range.InsertAfter vDesc
wdDoc.Bookmarks("bmN2").Range.InsertAfter vN2
wdDoc.Bookmarks("bmGuide").Range.InsertAfter vGuide
wdDoc.Bookmarks("bmBlock").Range.InsertAfter vBlock
wdDoc.Variables("wvItem").Value = vItem
ActiveDocument.Fields.Update
With wdDoc
Set wrdPic = .Bookmarks("bmImage").Range.InlineShapes.AddOLEObject(ClassType:="AcroExch.Document.7", Filename:="W:\Entity\Inspect\T&I\2016\Various Items\Photos\Sorted\" & vItem & ".pdf", LinkToFile:=False, DisplayAsIcon:=False)
wrdPic.ScaleHeight = 55
wrdPic.ScaleWidth = 55
End With
wdApp.Visible = True
wdApp.Activate
wdDoc.SaveAs "W:\Entity\Inspect\WSDATA\REPORTS\2016\" & vUnit & "\" & vItem & " " & vN2 & " THO.docx" 'Mid(ActiveDocument.Name, 1, Len(ActiveDocument.Name) - 4)
MoveHere:
ActiveWorkbook.Sheets("AllItems").Range("G" & ActiveCell.Offset(0, 8)).Value = "Yes"
ActiveWorkbook.Save
End Sub
I think DocVariables are easier to use that Bookmarks. Do a quick Google search on Word DocVariables. Get things setup correct in Word, and then run the script below.
Sub PushToWord()
Dim objWord As New Word.Application
Dim doc As Word.Document
Dim bkmk As Word.Bookmark
sWdFileName = Application.GetOpenFilename(, , , , False)
Set doc = objWord.Documents.Open(sWdFileName)
'On Error Resume Next
objWord.ActiveDocument.variables("FirstName").Value = Range("FirstName").Value
objWord.ActiveDocument.variables("LastName").Value = Range("LastName").Value
objWord.ActiveDocument.variables("AnotherVariable").Value = Range("AnotherVariable").Value
objWord.ActiveDocument.Fields.Update
'On Error Resume Next
objWord.Visible = True
End Sub
After much struggle with syntax, I have following code working, but I want to use error checking to determine if file is already open using a string.
(Disclosure: I have copied comparesheets from source that I will link when I find it)
Trying to replace this code
Set wbkA = Workbooks.Open(FileName:=wba)
with
Set wBook = Workbooks(wba) 'run time error subscript out of range
If wBook Is Nothing Then
Set wbkA = Workbooks.Open(FileName:=wba)
End If
But I have syntax problem with the string wba. What is proper way use string here?
Sub RunCompare_WS2()
Dim i As Integer
Dim wba, wbb As String
Dim FileName As Variant
Dim wkbA As Workbook
Dim wkbB As Workbook
Dim wBook As Workbook
wba = "C:\c.xlsm"
wbb = "C:\d.xlsm"
'Set wBook = Workbooks(FileName:=wba) 'compiler error named argument not found
'Set wBook = Workbooks(wba) 'run time error subscript out of range
'If wBook Is Nothing Then
'Set wbkA = Workbooks.Open(FileName:=wba)
'End If
Set wbkA = Workbooks.Open(FileName:=wba)
Set wbkB = Workbooks.Open(FileName:=wbb)
For i = 1 To Application.Sheets.Count
Call compareSheets(wbkA.Sheets(i), wbkB.Sheets(i))
Next i
wbkA.Close SaveChanges:=True
wbkB.Close SaveChanges:=False
MsgBox "Completed...", vbInformation
End Sub
Sub compareSheets(shtSheet1 As Worksheet, shtSheet2 As Worksheet)
Dim mycell As Range
Dim mydiffs As Integer
Dim DifFound As Boolean
DifFound = False
sDestFile = "C:\comp-wb.txt"
DestFileNum = FreeFile()
Open sDestFile For Append As DestFileNum
'For each cell in sheet2 that is not the same in Sheet1, color it lightgreen in first file
For Each mycell In shtSheet1.UsedRange
If Not mycell.Value = shtSheet2.Cells(mycell.Row, mycell.Column).Value Then
If DifFound = False Then
Print #DestFileNum, "Row,Col" & vbTab & vbTab & "A Value" & vbTab & vbTab & "B Value"
DifFound = True
End If
mycell.Interior.Color = 5296274 'LightGreen
Print #DestFileNum, mycell.Row & "," & mycell.Column, mycell.Value, shtSheet2.Cells(mycell.Row, mycell.Column).Value '& vbInformation
mydiffs = mydiffs + 1
End If
Next
Print #DestFileNum, mydiffs & " differences found in " & shtSheet1.Name
Close #DestFileNum
End Sub
You can use On Error Resume Next to ignore any error:
Const d As String = "C:\"
wba = "c.xlsm"
On Error Resume Next
Set wBook = Workbooks(wba)
On Error Goto 0
If wBook Is Nothing Then
Set wbkA = Workbooks.Open(d & wba) 'join string d & wba
End If
This will check to see if you have the file open.
Option Explicit
Function InputOpenChecker(InputFilePath) As Boolean
Dim WB As Workbook
Dim StrFileName As String
Dim GetFileName As String
Dim IsFileOpen As Boolean
InputOpenChecker = False
'Set Full path and name of file to check if already opened.
GetFileName = Dir(InputFilePath)
StrFileName = InputFilePath & GetFileName
IsFileOpen = False
For Each WB In Application.Workbooks
If WB.Name = GetFileName Then
IsFileOpen = True
Exit For
End If
Next WB
If you dont have it open, check to see if someone else does.
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open StrFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
'Set the FileLocked Boolean value to true
FileLocked = True
Err.Clear
End If
And one reason for your error could be the inclusion of "FileName:=" in the Workbooks.Open. Try;
Set wbkA = Workbooks.Open(wba)
Set wbkB = Workbooks.Open(wbb)
Fixed my code and reposting with corrections for clarity.
Note I moved to C:\temp since writing to root C:\ folder should not be used because many work computers have root folder locked for security as my colleague just found out!
Sub RunCompare_WS9() 'compare two WKbooks, all sheets write diff to text file
Dim i As Integer
Dim wba, wbb As String
Dim FileName As Variant
Dim wkbA As Workbook
Dim wkbB As Workbook
Dim wbook1 As Workbook
Dim wbook2 As Workbook
wba = "C:\test\c.xlsm"
wbb = "C:\test\d.xlsm"
On Error Resume Next
Set wbook1 = Workbooks(wba)
On Error GoTo 0
If wbook1 Is Nothing Then
Set wbkA = Workbooks.Open(wba)
End If
On Error Resume Next
Set wbook2 = Workbooks(wbb)
On Error GoTo 0
If wbook2 Is Nothing Then
Set wbkB = Workbooks.Open(wbb)
End If
For i = 1 To Application.Sheets.Count
Call compareSheets(wbkA.Sheets(i), wbkB.Sheets(i))
Next i
wbkA.Close SaveChanges:=True
wbkB.Close SaveChanges:=False
MsgBox "Completed...", vbInformation
End Sub
Sub compareSheets(shtSheet1 As Worksheet, shtSheet2 As Worksheet)
Dim mycell As Range
Dim mydiffs As Integer
Dim DifFound As Boolean
DifFound = False
sDestFile = "C:\Test\comp2-wb.txt"
DestFileNum = FreeFile()
Open sDestFile For Append As DestFileNum
'For each cell in sheet2 that is not the same in Sheet1, color it lightgreen in first file
For Each mycell In shtSheet1.UsedRange
If Not mycell.Value = shtSheet2.Cells(mycell.Row, mycell.Column).Value Then
If DifFound = False Then
Print #DestFileNum, "Row,Col" & vbTab & vbTab & "A Value" & vbTab & vbTab & "B Value"
DifFound = True
End If
mycell.Interior.Color = 5296274 'LightGreen
Print #DestFileNum, mycell.Row & "," & mycell.Column, mycell.Value, shtSheet2.Cells(mycell.Row, mycell.Column).Value '& vbInformation
mydiffs = mydiffs + 1
End If
Next
Print #DestFileNum, mydiffs & " differences found in " & shtSheet1.Name
Close #DestFileNum
End Sub
i currently have the problem that everytime im trying to open a word document via vba/excel im getting an Application/Object Error. My Idea is that im trying to compare data from two tables and deleting the bad results. After that i want to insert the whole table to the existing word document what im selecting from the selection/opening window.
My Code
Private Sub CommandButton1_Click()
Dim varDatei As Variant
Dim wordDatei As Variant
Dim objExcel As New Excel.Application
Dim objSheet As Object
Dim wordDoc As Object
Dim extBereich As Variant
Dim intBereich As Variant
Dim appWord As Object
Set intBereich = ThisWorkbook.Sheets(1).Range("A4:A11")
Dim loopStr As Variant
Dim loopStr2 As Variant
Dim found() As Variant
Dim loopInt As Integer
Dim endStr As Variant
Dim extBereich2 As Variant
loopInt = 1
varDatei = Application.GetOpenFilename("Excel-Dateien (*.xlsx), *.xlsx")
If varDatei <> False Then
objExcel.Workbooks.Open varDatei
Set objSheets = objExcel.Sheets(1)
objSheets.Activate
LetzteZeile = objSheets.Cells(objSheets.Rows.Count, 3).End(xlUp).Row
Set extBereich = objSheets.Range("B3:B" & LetzteZeile)
ReDim found(1 To LetzteZeile)
For Each loopStr In extBereich
objSheets.Range("F" & loopStr.Row) = "Good"
objSheets.Cells(loopStr.Row, 6).Interior.ColorIndex = 4
For Each loopStr2 In intBereich
If (StrComp(loopStr, loopStr2, vbBinaryCompare) = 0) = True Then
found(loopInt) = objSheets.Range("A" & loopStr.Row)
loopInt = loopInt + 1
objSheets.Cells(loopStr.Row, 6) = "Bad"
objSheets.Cells(loopStr.Row, 6).Interior.ColorIndex = 3
Exit For
End If
Next loopStr2
Next loopStr
loopStr = ""
If (loopInt <> 1) Then
endStr = "This is bad:" & vbLf
For Each loopStr In found
If (Trim(loopStr & vbNullString) <> vbNullString) Then
endStr = endStr & loopStr & vbLf
End If
Next loopStr
MsgBox (endStr)
Else
MsgBox ("Everythings good")
End If
Set appWord = CreateObject("Word.Application")
appWord.DisplayAlerts = False
Debug.Print ("123")
Set wordDoc = appWord.Documents.Open(Application.GetOpenFilename("Word-Dateien (*.doc;*.docx;),*.doc;*.docx"))
wordDoc.Activate
Debug.Print ("456")
loopStr = ""
For Each loopStr In extBereich
If (objSheets.Cells(loopStr.Row, 6).Interior.ColorIndex = 3) Then
objSheets.Range("A" & loopStr.Row & ":" & "E" & loopStr.Row).Delete
End If
Next loopStr
objSheets.Range(Columns(2), Columns(4)).Delete
objSheets.Range("A3:B" & LetzteZeile).Copy
appWord.Documents(1).Range.Paste
With appWord.Documents(1).Tables(1)
.Columns.AutoFit
End With
appWord.PrintOut
objExcel.Quit
appWord.Quit
Set appWord = Nothing
Set objExcel = Nothing
Debug.Print loopInt
Else
MsgBox "Error"
End If
End Sub
Maybe someone of you knew whats the problem?
Error Code is 1004 - Application- or object Error
With best regards and thanks for answering
Your problem is with the line:
objSheets.Range(Columns(2), Columns(4)).Delete
You need to specify where the columns are, e.g.
objSheets.Range(objSheets.Columns(2), objSheets.Columns(4)).Delete