I am having trouble debugging my code. I have an array with the criterial of an autofilter column. My code is supposed to loop through the array, open a set of files and copy-paste information into my workbook.
When I run the code it does not autofiler to the desired criterial and shows a Run-time error 1004. I already tried searching for solutions or similar problems, but found nothing. I also tried recording a macro to change the approach, but when trying to implement the loop it does not work :(
Any help is appreaciated!
Sub Update_Database()
Dim directory As String
Dim fileName As String
Dim my_array() As String
Dim iLoop As Integer
ReDim my_array(18)
my_array(0) = "Aneng"
my_array(1) = "Bayswater"
my_array(2) = "Bad Blankenburg"
my_array(3) = "Halstead"
my_array(4) = "Jorf Lasfar"
my_array(5) = "Kolkatta"
my_array(6) = "Marysville"
my_array(7) = "Northeim"
my_array(8) = "Ponta Grossa"
my_array(9) = "Puchov"
my_array(10) = "Renca"
my_array(11) = "Padre Hurtado"
my_array(12) = "Shanxi"
my_array(13) = "San Luis Potosi"
my_array(14) = "Szeged"
my_array(15) = "Tampere"
my_array(16) = "Uitenhage"
my_array(17) = "Veliki Crljeni"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
directory = .SelectedItems(1)
Err.Clear
End With
fileName = Dir(directory & "\", vbReadOnly)
Dim mwb As Workbook
Set mwb = Workbooks("OEE_Database_Final.xlsm")
Do While fileName <> ""
For iLoop = LBound(my_array) To UBound(my_array)
On erro GoTo ProcExit
With Workbooks.Open(fileName:=directory & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
Selection.AutoFilter Field:=1, Criterial:=my_array(iLoop)
mwb.Worksheets(8).Range("O9:Z2945") = .Worksheets(8).Range("O9:Z2945").Value2
.Close SaveChanges:=False
End With
fileName = Dir
Next iLoop
Loop
ActiveSheet.ShowAllData
ProcExit:
Exit Sub
End Sub
Related
I'm trying to get a macro for Excel 2007to open a folder with a bunch of images in them. Then Create a new workbook and embed the images into it.
Everything works if I comment out the line Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310 If I uncomment that line I get "Run-time error '434': Object required"
I've check that Sheet.Shapes is returning a Shapes object, it is but the Shapes object is empty. When I try Sheet.Shapes,AddPicture on a workbook that is opened outside of the macro, it adds the images. I've also checked that Sheet.Shapes.AddShape works with the workbook opened in the macro, it does.
At this point, I'm at a lose for what the issue might be. Does anyone have any experience with this sort of thing? Should I be using a different method? Thanks in advance for any help or guidance.
Sub Macro1()
Dim ImagePath, Flist
ImagePath = GetFolder()
If ImagePath = "" Then Exit Sub
Flist = FileList(ImagePath)
Name = "C:\target.xlsm"
Set Book = Workbooks.Add
Set Sheet = Book.Sheets(1)
For i = 1 To 5
cell = "C" + CStr(i)
F = ImagePath + "\" + Flist(i - 1)
Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310
Next
Book.SaveAs FileName:=Name, FileFormat:=52
Book.Close
End Sub
Function FileList(ByVal fldr As String) As Variant
'Lists all the files in the current directory
'Found at http://www.ozgrid.com/forum/showthread.php?t=71409
Dim sTemp As String, sHldr As String
If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
sTemp = Dir(fldr & "*.png")
If sTemp = "" Then
FileList = False
Exit Function
End If
Do
sHldr = Dir
If sHldr = "" Then Exit Do
sTemp = sTemp & "|" & sHldr
Loop
FileList = Split(sTemp, "|")
End Function
Function GetFolder() As String
Folder:
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "New Screenshot Folder"
.Show
num = .SelectedItems.Count
If .SelectedItems.Count = 0 Then
GetFolder = ""
Else: GetFolder = .SelectedItems(1)
End If
End With
End Function
You can't define a cell by creating the string "C1", that's just the address. The way you did it, cell is a string and a string doesn't have any properties. What you want is a range object so either use
Dim cell As Range
Set cell = sheet.Range("C" & i)
or
Dim cell As Range
Set cell = sheet.Cells(i, 3)
You should always Dim all variables, use Option Explicit on top of your module so you don't forget it ;)
This will often prevent mistakes. Of course you should Dim them with the correct type, i.e. Dim FilePath As String.
The correct command would be:
Sheet.Shapes.AddPicture Filename:=F, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=Range(cell).Left + 5, Top:=Range(cell).Top + 5, Width:=560, Height:=310
I strongly advise you to change your Name variable name, as it will cause errors on recent versions of excel.
I have code which compares two folders (textFiles & ExcelFiles), to find if all textFiles are converted to Excel. If not, it calls a function that does this. Everything works well, but when I open the Excel file, the format may change from a row to another in the same column.
This is my code:
Sub LookForNew()
Dim dTxt As String, dExcel As String, key As String
Dim i As Integer
Dim oFileExcel, tFileExl, oFileExl, fso, filsTxt, filsExcel, fil, exl
Set fso = CreateObject("Scripting.FileSystemObject")
Set filsTxt = fso.GetFolder("C:\txtFiles").Files
Set filsExcel = fso.GetFolder("C:\excelFiles").Files
Set oFileExcel = CreateObject("Scripting.Dictionary")
Set tFileExl = CreateObject("Scripting.Dictionary")
Set oFileExl = CreateObject("Scripting.Dictionary")
i = 0
For Each fil In filsTxt
dTxt = fil.Name
dTxt = Left(dTxt, InStr(dTxt, ".") - 1)
For Each exl In filsExcel
dExcel = exl.Name
dExcel = Left(dExcel, InStr(dExcel, ".") - 1)
key = CStr(i)
oFileExcel.Add dExcel, "key"
i = i + 1
Next exl
If Not (oFileExcel.Exists(dTxt)) Then
Call tgr
End If
Next fil
Set fso = Nothing
End Sub
Sub tgr()
Const txtFldrPath As String = "C:\txtFiles"
Const xlsFldrPath As String = "C:\excelFiles"
Dim CurrentFile As String: CurrentFile = Dir(txtFldrPath & "\" & "*.txt")
Dim strLine() As String
Dim LineIndex As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
While CurrentFile <> vbNullString
LineIndex = 0
Close #1
Open txtFldrPath & "\" & CurrentFile For Input As #1
While Not EOF(1)
LineIndex = LineIndex + 1
ReDim Preserve strLine(1 To LineIndex)
Line Input #1, strLine(LineIndex)
'STRIP TABS OUT AND REPLACE WITH A SPACE!!!!!
strLine(LineIndex) = Replace(strLine(LineIndex), Chr(9), Chr(32))
Wend
Close #1
With ActiveSheet.Range("A1").Resize(LineIndex, 1)
.Value = WorksheetFunction.Transpose(strLine)
'DEFINE THE OPERATION FULLY!!!!
.TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
End With
ActiveSheet.UsedRange.EntireColumn.AutoFit
ActiveSheet.Copy
ActiveWorkbook.SaveAs xlsFldrPath & "\" & Replace(CurrentFile, ".txt", ".xlsx"), xlOpenXMLWorkbook
ActiveWorkbook.Close False
ActiveSheet.UsedRange.ClearContents
CurrentFile = Dir
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This is the picture:
The General format cell changes for some records and becomes a number exp: 4'927'027.00 should be 4927027 like the others.
this is the text file lines
And I want to put a msgBox when there's no Files to convert in "LookForNew" function, but I don't know where.
Question 1: I open the Excel file, the format may change from a row to another in the same column.
Answer: The problem probable lies in your text file. Note what row ,column, and value that isn't formatted properly. Next go to that line and column in your text file. You'll most likely see 4,927,027 or "4927027". In either case Excel might mistake it for a string value.
Question 2: I want to put a msgBox when there's no Files to convert in "LookForNew" function, but I don't know where.
Put a counter in your If Files Exist. You should have your MsgBox after you exit your file loop. - Next fil
This line is miss leading:
oFileExcel.Add dExcel, "key"
correct syntax
dictionary.add key, value
Keys are unique identifiers. Before you add a key to a dictionary you should test to see if the key exist
If not oFileExcel.Exists dExcel then oFileExcel.Add dExcel, ""
Values are references to objects or values.
This line adds the exl file object to oFileExcel dictionary
If not oFileExcel.Exists dExcel then oFileExcel.Add dExcel, exl
This line retrieves the value
Set exl = oFileExcel("SomeKey")
The error is being thrown because you are adding the same key twice. The key values are the name of the Excel file without an extension. Example.xls and Example.xlsx will produce the same key.
That being said, there is no need to use a dictionary. Or to do a file loop in tgr().
I better approach would be
Sub Main
For each textfile
basename = get text file basename
xlfile = xlFileDirectory + baseFileName + excel file extension
if not xlfile Exists then call CreateExcelFromTxt f.Path, xlFileName
End Sub
Sub CreateExcelFromTxt( txtFile, xlFileName)
Open txtFile
Build strLine
Create Excel -> xlFileName
Add strLine to xlFileName
run TextToColumns
End Sub
Here is a starter template
Sub LookForNew()
Const xlFileDirectory = "C:\excelFiles\"
Const txtFileDirectory = C:\txtFiles\"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim fso, fld , f, xlFileName
Set fso = WScript.CreateObject("Scripting.Filesystemobject")
Set fld = fso.GetFolder(txtFileDirectory)
Set txtFiles = fso.GetFolder(txtFileDirectory).Files
For Each f In txtFiles
baseFileName = Left(f.Name,InStrRev(f.Name,".")-1)
xlFilePath = xlFileDirectory & baseFileName & ".xlsx"
If Not fso.FileExists(xlFilePath ) Then CreateExcelFromText f.Path, xlFileName
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub CreateExcelFromText(txtFileName, xlFileName)
End Sub
I'm trying to get a Macro working to merge cells with duplicate data. It will work on small numbers of cells, but I get the following error if I try to run it on a larger group of cells. I'm not sure if there's a more efficient way for excel to run through this.
Run-Time error '1004':
Method 'Range' of object '_Global' failed
Here's the code:
Sub MergeDuplicates()
Dim varData As Variant, varContent As Variant
Dim strMyRange As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strMyRange = ActiveCell.Address
varContent = ActiveCell.Value
For Each varData In Selection.Cells
If varData.Value <> varContent Then
strMyRange = strMyRange & ":" & Cells(varData.Row - 1, varData.Column).Address & ", " & Cells(varData.Row, varData.Column).Address
varContent = Cells(varData.Row, varData.Column).Value
End If
Next
strMyRange = strMyRange & Mid(Selection.Address, InStr(1, Selection.Address, ":"), Len(Selection.Address))
Range(strMyRange).Merge
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have recreated the issue using the code you posted and it is working for me. I did what you suggested and put the merge into the For loop. Then I split strMyRange using the comma as the delimiter. I set up a test to look for the ":" character in TestArray(0). If it is in that target string, then I know it is ready for the merge. After that I reset strMyRange to the TestArray(1) which is the beginning of the next range.
Note: I was able to step through it with the debugger with 100 cells and it worked. Then I tried running it without any code breakpoints, but it merged all the selected cells. I put a 1 second wait statement right before the final merge and that seems to work.
Here is the code:
Sub MergeDuplicates()
Dim varData As Variant, varContent As Variant
Dim strMyRange As String
Dim TestArray() As String
Dim target As String
Dim pos As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strMyRange = ActiveCell.Address
varContent = ActiveCell.Value
For Each varData In Selection.Cells
If varData.Value <> varContent Then
strMyRange = strMyRange & ":" & Cells(varData.Row - 1, varData.Column).Address & ", " & Cells(varData.Row, varData.Column).Address
TestArray = Split(strMyRange, ",")
target = TestArray(0)
pos = InStr(target, ":")
If (pos > 0) Then
Range(target).Merge
strMyRange = TestArray(1)
End If
varContent = Cells(varData.Row, varData.Column).Value
End If
Next
strMyRange = strMyRange & Mid(Selection.Address, InStr(1, Selection.Address, ":"), Len(Selection.Address))
Application.Wait (Now + #12:00:01 AM#) 'This helps the application run OK if there are no breakpoints.
Range(strMyRange).Merge
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I'm trying to set up the dashboard I just created to automatically(well, as soon as it gets opened again) update itself as I make changes in the future. I've worked out the following method of doing it, but I keep getting a 'Type Mismatch' error on the line marked with **. I feel like I"m missing something pretty obvious here, but for the life of me, I can't figure it out. Any ideas?
Private Sub Workbook_Open()
Dim UpDateBook As Workbook
Dim CurrVer As String
Dim AdminFile As String
Dim AdminFolder As String
Dim MyPath As String
''Change the next two according to where the admin file will be located.
AdminFile = "\\dallfile\Databases\Reports\Dashboard\Dashboard Update.xlsx"
AdminFolder = "\\dallfile\Databases\Reports\Dashboard"
MyPath = ThisWorkbook.Path
MyPath = MyPath & "\"
Application.ScreenUpdating = False
Set UpDateBook = Workbooks.Open(AdminFile, , True)
**CurrVer = Workbooks(UpDateBook).Sheets("Version_Log").Range("A5000").End(xlUp).Value
CurrVer = CurrVer & ".xlsm"
If ThisWorkbook.Name <> CurrVer Then
MsgBox ("There is a new update for your file available. It will be loaded as soon as you press OK")
Workbooks.Open Filename:=AdminFolder & CurrVer
Application.EnableEvents = False
Workbooks(CurrVer).SaveAs Filename:=MyPath & CurrVer, FileFormat:=xlNormal
Application.EnableEvents = True
With ThisWorkbook
.Saved = True
.ChangeFileAccess Mode:=xlReadOnly
Kill pathname:=.FullName
.Close savechanges:=False
End With
End If
Application.ScreenUpdating = True
End Sub
I think this is because you are using your workbook object incorrectly.
You set the workbook here..
Set UpDateBook = Workbooks.Open(AdminFile, , True)
and then you should use it like this.
CurrVer = UpDateBook.Sheets("Version_Log").Range("A5000").End(xlUp).Value
Just a matter of syntax. Once you have:
Set UpDateBook = Workbooks.Open(AdminFile, , True)
You should use it like:
CurrVer = UpDateBook.Sheets("Version_Log").Range("A5000").End(xlUp).Value
I have exhausted my search capabilities looking for a solution to this. Here is an outline of what I would like to do:
User opens macro-enabled Excel file
Immediate prompt displays for user to enter or select file path of desired workbooks. They will need to select two files, and the file names may not be consistent
After entering the file locations, the first worksheet from the first file selection will be copied to the first worksheet of the macro-enabled workbook, and the first worksheet of the second file selection will be copied to the second worksheet of the macro-enabled workbook.
I've come across some references to ADO, but I am really not familiar with that yet.
Edit: I have found a code to import data from a closed file. I will need to tweak the range to return the variable results.
Private Function GetValue(path, file, sheet, ref)
path = "C:\Users\crathbun\Desktop"
file = "test.xlsx"
sheet = "Sheet1"
ref = "A1:R30"
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
Sub TestGetValue()
path = "C:\Users\crathbun\Desktop"
file = "test"
sheet = "Sheet1"
Application.ScreenUpdating = False
For r = 1 To 30
For C = 1 To 18
a = Cells(r, C).Address
Cells(r, C) = GetValue(path, file, sheet, a)
Next C
Next r
Application.ScreenUpdating = True
End Sub
Now, I need a command button or userform that will immediately prompt the user to define a file path, and import the data from that file.
I don't mind if the files are opened during process. I just didn't want the user to have to open the files individually. I just need them to be able to select or navigate to the desired files
Here is a basic code. This code asks user to select two files and then imports the relevant sheet into the current workbook. I have given two options. Take your pick :)
TRIED AND TESTED
OPTION 1 (Import the Sheets directly instead of copying into sheet1 and 2)
Option Explicit
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook
Dim Ret1, Ret2
Set wb1 = ActiveWorkbook
'~~> Get the first File
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select first file")
If Ret1 = False Then Exit Sub
'~~> Get the 2nd File
Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select Second file")
If Ret2 = False Then Exit Sub
Set wb2 = Workbooks.Open(Ret1)
wb2.Sheets(1).Copy Before:=wb1.Sheets(1)
ActiveSheet.Name = "Blah Blah 1"
wb2.Close SaveChanges:=False
Set wb2 = Workbooks.Open(Ret2)
wb2.Sheets(1).Copy After:=wb1.Sheets(1)
ActiveSheet.Name = "Blah Blah 2"
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wb1 = Nothing
End Sub
OPTION 2 (Import the Sheets contents into sheet1 and 2)
Option Explicit
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook
Dim Ret1, Ret2
Set wb1 = ActiveWorkbook
'~~> Get the first File
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select first file")
If Ret1 = False Then Exit Sub
'~~> Get the 2nd File
Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select Second file")
If Ret2 = False Then Exit Sub
Set wb2 = Workbooks.Open(Ret1)
wb2.Sheets(1).Cells.Copy wb1.Sheets(1).Cells
wb2.Close SaveChanges:=False
Set wb2 = Workbooks.Open(Ret2)
wb2.Sheets(1).Cells.Copy wb1.Sheets(2).Cells
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wb1 = Nothing
End Sub
The function below reads data from a closed Excel file and returns the result in an array. It loses formatting, formulas etc. You might want to call the isArrayEmpty function (at the bottom) in your main code to test that the function returned something.
Public Function getDataFromClosedExcelFile(parExcelFileName As String, parSheetName As String) As Variant
'see http://www.ozgrid.com/forum/showthread.php?t=19559
'returns an array (1 to nRows, 1 to nCols) which should be tested with isArrayEmpty in the calling function
Dim locConnection As New ADODB.Connection
Dim locRst As New ADODB.Recordset
Dim locConnectionString As String
Dim locQuery As String
Dim locCols As Variant
Dim locResult As Variant
Dim i As Long
Dim j As Long
On Error GoTo error_handler
locConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & parExcelFileName & ";" _
& "Extended Properties=""Excel 8.0;HDR=YES"";"
locQuery = "SELECT * FROM [" & parSheetName & "$]"
locConnection.Open ConnectionString:=locConnectionString
locRst.Open Source:=locQuery, ActiveConnection:=locConnection
If locRst.EOF Then 'Empty sheet or only one row
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''' FIX: an empty sheet returns "F1"
'''''' http://support.microsoft.com/kb/318373
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" Then Exit Function 'Empty sheet
ReDim locResult(1 To 1, 1 To locRst.Fields.Count) As Variant
For i = 1 To locRst.Fields.Count
locResult(1, i) = locRst.Fields(i - 1).Name
Next i
Else
locCols = locRst.GetRows
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''' FIX: an empty sheet returns "F1"
'''''' http://support.microsoft.com/kb/318373
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" And UBound(locCols, 2) = 0 And locCols(0, 0) = "" Then Exit Function 'Empty sheet
ReDim locResult(1 To UBound(locCols, 2) + 2, 1 To UBound(locCols, 1) + 1) As Variant
If locRst.Fields.Count <> UBound(locCols, 1) + 1 Then Exit Function 'Not supposed to happen
For j = 1 To UBound(locResult, 2)
locResult(1, j) = locRst.Fields(j - 1).Name
Next j
For i = 2 To UBound(locResult, 1)
For j = 1 To UBound(locResult, 2)
locResult(i, j) = locCols(j - 1, i - 2)
Next j
Next i
End If
locRst.Close
locConnection.Close
Set locRst = Nothing
Set locConnection = Nothing
getDataFromClosedExcelFile = locResult
Exit Function
error_handler:
'Wrong file name, sheet name, or other errors...
'Errors (#N/A, etc) on the sheet should be replaced by Null but should not raise an error
If locRst.State = ADODB.adStateOpen Then locRst.Close
If locConnection.State = ADODB.adStateOpen Then locConnection.Close
Set locRst = Nothing
Set locConnection = Nothing
End Function
Public Function isArrayEmpty(parArray As Variant) As Boolean
'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False
End Function
Sample use:
Sub test()
Dim data As Variant
data = getDataFromClosedExcelFile("myFile.xls", "Sheet1")
If Not isArrayEmpty(data) Then
'Copies content on active sheet
ActiveSheet.Cells(1,1).Resize(UBound(data,1), UBound(data,2)) = data
End If
End Sub