I have been trying to work on powerpoint that has an excel database in background.
For now I am having trouble passing sheets as arguement in PPT VBA. The function lastrow and lastcoulmn return an error that "user-defined type not defined". Help would be appreciated. thanks.
Dim oXLApp As Object
Dim oWb As Object
Dim Deps As Excel.Range
Dim Dep, Shift, Name, EmpNo, Sup As String
Dim Sups As Excel.Range
Dim Shifts As Excel.Range
Public Sub getexceldata()
Dim str As String
Set oXLApp = CreateObject("Excel.Application")
Set oWb = oXLApp.Workbooks.Open(ActivePresentation.Path & "\" & "Property Wide.xlsm")
'Shifts
Set Shifts = oWb.Sheets(4).Range("A1:A" & lastRow(oWb.Sheets(4), "a"))
'departments
Set Deps = oWb.Sheets(3).Range("A1:" & Chr(lastColumn(oWb.Sheets(3), "1") + 64) & "1")
'supervisors
End Sub
Public Function lastRow(ByVal SheetA As Excel.Application.Sheet, Optional Columnno As Char = "/") As Long
If (Columnno = "/") Then
Set lastRow = SheetA.UsedRange.Row - 1 + SheetA.UsedRange.Rows.Count
Else
Set lastRow = SheetA.Range(Columno & Rows.Count).End(xlUp).Row
End If
End Function
Public Function lastColumn(ByVal SheetA As Excel.Application.Sheet, Optional rowno As Char = "/") As Integer
If (rowno = "/") Then
Set lastColumn = SheetA.UsedRange.Column - 1 + SheetA.UsedRange.Columns.Count
Else
Set lastColumn = SheetA.Cells(rowno, Columns.Count).End(xlToLeft).Column
End If
End Function
The first issue is that CHAR is not a valid variable type so I would suggest changing this to string.
Next make sure to include the Microsoft Office Excel 14.0 Object Library in your code reference.
With that you can make some slight adjustment to your code an everything should work.
Dim oXLApp As Object
Dim oWb As Object
Dim Deps As Excel.Range
Dim Dep, Shift, Name, EmpNo, Sup As String
Dim Sups As Excel.Range
Dim Shifts As Excel.Range
Public Sub getexceldata()
Dim str As String
Set oXLApp = CreateObject("Excel.Application")
Set oWb = oXLApp.Workbooks.Open(ActivePresentation.Path & "\" & "Property Wide.xlsm")
'Shifts
Set Shifts = oWb.Sheets(4).Range("A1:A" & lastRow(oWb.Sheets(4), "a"))
'departments
Set Deps = oWb.Sheets(3).Range("A1:" & Chr(lastColumn(oWb.Sheets(3), "1") + 64) & "1")
'supervisors
End Sub
Public Function lastRow(ByVal SheetA As Worksheet, Optional Columnno As String = "/") As Long
If (Columnno = "/") Then
Set lastRow = SheetA.UsedRange.Row - 1 + SheetA.UsedRange.Rows.Count
Else
Set lastRow = SheetA.Range(Columno & Rows.Count).End(xlUp).Row
End If
End Function
Public Function lastColumn(ByVal SheetA As Worksheet, Optional rowno As String = "/") As Integer
If (rowno = "/") Then
Set lastColumn = SheetA.UsedRange.Column - 1 + SheetA.UsedRange.Columns.Count
Else
Set lastColumn = SheetA.Cells(rowno, Columns.Count).End(xlToLeft).Column
End If
End Function
With that you should have what you need.
Related
I am trying to pull data from a folder containing 300 Workbooks, each named 001, 002 etc.
I am only interested in pulling the data from column G of each file and copying it into a separate folder (each file does not have the same amount if data in row G)
I have been able to copy the data across, but I can't seem to get it to move past column 2 and instead writes over the previous column.
The output needed is:
data from column G workbook"001" pasted into "new sheet" column A
data from column G workbook"002" pasted into "new sheet" column B
and so on
Each file in the folder of 300 only has 1 worksheet each, each labelled: 001,002,...,300
This is the code I already had which results in 2 columns of data where 1 gets replaced by each new sheet instead.
Any help to solve this issue would be greatly appreciated.
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = "C:..."
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
LastRow = Range("G1").CurrentRegion.Rows.Count
Range("G1", Range("G" & LastRow)).Copy ThisWorkbook.Sheets("Sheet1").Range(CurS.Cells(ThisRow, ThisCol + 1), CurS.Cells(ThisRow, ThisCol + CurS.Cells(ThisRow, InfCol).Value))
ActiveWorkbook.Save
ActiveWorkbook.Close
MyFile = Dir
Loop
End Sub
To properly copy in a new column each time, you need a variable that increments during each loop to offset by one each time. When you use ThisCol + 1 you're always getting the same value because ThisCol is not updated.
Something like this:
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = ReplacewithyouFilePath
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
'Let's keep a reference to the workbook
Dim wb As Workbook
Set wb = Workbooks.Open(Filepath & MyFile)
'Let's keep a reference to the first sheet where the data is
Dim ws As Worksheet
Set ws = wb.Sheets(1)
Dim LastRow As Long
LastRow = ws.Range("G1").CurrentRegion.Rows.Count
'We create a variable to increment at each column
Dim Counter As Long
'Let's make the copy operation using the Counter
ws.Range("G1", ws.Range("G" & LastRow)).Copy CurS.Range(CurS.Cells(ThisRow, ThisCol + Counter), CurS.Cells(ThisRow + LastRow - 1, ThisCol + Counter))
'We increment the counter for the next file
Counter = Counter + 1
'We use wb to make sure we are referring to the right workbook
wb.Save
wb.Close
MyFile = Dir
'We free the variables for good measure
Set wb = Nothing
Set ws = Nothing
Loop
End Sub
Import Columns
Sub ImportColumns()
Const FOLDER_PATH As String = "C:\Test"
Const FILE_EXTENSION_PATTERN As String = "*.xls*"
Const SOURCE_WORKSHEET_ID As Variant = 1
Const SOURCE_COLUMN As String = "G"
Const SOURCE_FIRST_ROW As Long = 1
Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_COLUMN_OFFSET As Long = 1
Dim pSep As String: pSep = Application.PathSeparator
Dim FolderPath As String: FolderPath = FOLDER_PATH
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Dim DirPattern As String: DirPattern = FolderPath & FILE_EXTENSION_PATTERN
Dim SourceFileName As String: SourceFileName = Dir(DirPattern)
If Len(SourceFileName) = 0 Then
MsgBox "No files found.", vbExclamation
Exit Sub
End If
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim sfCell As Range
Dim slCell As Range
Do While Len(SourceFileName) > 0
If StrComp(SourceFileName, "Text to column.xlsm", vbTextCompare) _
<> 0 Then ' Why 'Exit Sub'? Is this the destination file?
Set swb = Workbooks.Open(FolderPath & SourceFileName, True, True)
Set sws = swb.Worksheets(SOURCE_WORKSHEET_ID)
Set sfCell = sws.Cells(SOURCE_FIRST_ROW, SOURCE_COLUMN)
Set slCell = sws.Cells(sws.Rows.Count, SOURCE_COLUMN).End(xlUp)
Set srg = sws.Range(sfCell, slCell)
srg.Copy dfCell
' Or, if you only need values without formulas and formats,
' instead, use the more efficient:
'dfCell.Resize(srg.Rows.Count).Value = srg.Value
Set dfCell = dfCell.Offset(, DESTINATION_COLUMN_OFFSET) ' next col.
swb.Close SaveChanges:=False ' we are just reading, no need to save!
'Else ' it's "Text to column.xlsm"; do nothing
End If
SourceFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Columns imported.", vbInformation
End Sub
I am completely new to VBA, but I have CSV files(same format for all of them), and I want to import them to a single sheet on Excel. I was able to read the CSV file according to this code:
Sub R_AnalysisMerger()
Dim WSA As Worksheet
Dim bookList As Workbook
Dim SelectedFiles() As Variant
Dim NFile As Long
Dim FileName As String
Dim ws As Worksheet, vDB As Variant, rngT As Range
Application.ScreenUpdating = False
'Selects the CSV files as SELECTED FILES
Set ws = ThisWorkbook.Sheets(1)
ws.UsedRange.Clear 'Clears current worksheet
SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.csv*), *.csv*", MultiSelect:=True) 'Selects csv files
For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
FileName = SelectedFiles(NFile)
Set bookList = Workbooks.Open(FileName, Format:=2)
Set WSA = bookList.Sheets(1)
With WSA
vDB = .UsedRange
Set rngT = ws.Range("a" & Rows.count).End(xlUp)(2)
If rngT.Row = 2 Then Set rngT = ws.Range("A1")
rngT.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
bookList.Close (0)
End With
Next
Application.ScreenUpdating = True
ws.Range("A1").Select
But I have additional requirements:
Skip the first column.
Skip the first four rows.
Remove a certain String from each word in the fifth row.
Im used to java, and usually I would read each line with a "for" loop and set "if" statements to skip the first row and four columns and remove the string from each string if it was present.
I don't know how to do this with this code. From what I understand it just copies the whole CSV file into the sheet?
This solution is based on reading CSV as textstream. I have tried to include feature that makes possible most all things like selecting columns, Rows and so on.
Sub ImportCSV()
Dim fso As New IWshRuntimeLibrary.FileSystemObject
Dim txtStream As IWshRuntimeLibrary.TextStream
Dim files As IWshRuntimeLibrary.files
Dim file As IWshRuntimeLibrary.file
Dim txtLine As String
Dim lineCount As Integer
Dim lastRow As Integer
Dim lineCol As Variant
Dim rng As Range
Application.ScreenUpdating = False
ThisWorkbook.Sheets(1).usedRange.Delete
Set rng = ThisWorkbook.Sheets(1).usedRange
lastRow = 1
Set files = fso.GetFolder("path\folder").files
For Each file In files
If file.Name Like "*.csv" Then
Set txtStream = file.OpenAsTextStream(ForReading, TristateUseDefault)
txtStream.SkipLine ' skip first line, since it containes headers
lineCount = 1
Do
txtLine = txtStream.ReadLine
If lineCount = 5 Then
txtLine = Replace(txtLine, "stringToReplace", "StringToReplcaeWith") ' replace certain string from words in 5'th row
End If
lineCount = lineCount + 1
lineCol = sliceStr(Split(txtLine, ";"), startIdx:=4) ' slice the array so to skip four first columns
For iCol = 0 To UBound(lineCol) ' write columns to last row
rng(lastRow, iCol + 1).Value = lineCol(iCol)
Next iCol
lastRow = lastRow + 1
'Debug.Print Join(lineCol, ";") ' debug
Loop Until txtStream.AtEndOfStream
End If
Next file
Application.ScreenUpdating = True
End Sub
This is the slicer function
Function sliceStr(arr As Variant, startIdx As Integer, Optional stopIdx As Integer = 0) As String()
If stopIdx = 0 Then
stopIdx = UBound(arr)
End If
Dim tempArrStr() As String
ReDim tempArrStr(stopIdx - startIdx)
Dim counter As Integer
counter = 0
For i = startIdx To stopIdx
tempArrStr(counter) = arr(i)
counter = counter + 1
Next
sliceStr = tempArrStr
End Function
I just did a simple test and the code below seems to work. Give it a go, and feedback.
Sub Demo()
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fld As Object 'Folder
Dim fl As Object 'File
Dim Mask As String
Application.ScreenUpdating = False
Dim newWS As Worksheet
Set newWS = Sheets.Add(before:=Sheets(1))
Set fso = CreateObject("scripting.FileSystemObject") ' late binding
'Set fso = New FileSystemObject 'or use early binding (also replace Object types)
Set fldStart = fso.GetFolder("C:\Users\ryans\OneDrive\Desktop\output\") ' <-- use your FileDialog code here
Mask = "*.csv"
'Debug.Print fldStart.Path & ""
ListFiles fldStart, Mask
For Each fld In fldStart.SubFolders
ListFiles fld, Mask
ListFolders fld, Mask
Next
Dim myWB As Workbook, WB As Workbook
Set myWB = ThisWorkbook
Dim L As Long, t As Long, i As Long
L = myWB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
t = 1
For i = 1 To L
Workbooks.OpenText Filename:=myWB.Sheets(1).Cells(i, 1).Value, DataType:=xlDelimited, Tab:=True
Set WB = ActiveWorkbook
lrow = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
WB.Sheets(1).Range("B4:E" & lrow).Copy newWS.Cells(t, 2)
t = myWB.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
WB.Close False
Next
myWB.Sheets(1).Columns(1).Delete
Application.ScreenUpdating = True
End Sub
Sub ListFolders(fldStart As Object, Mask As String)
Dim fld As Object 'Folder
For Each fld In fldStart.SubFolders
'Debug.Print fld.Path & ""
ListFiles fld, Mask
ListFolders fld, Mask
Next
End Sub
Sub ListFiles(fld As Object, Mask As String)
Dim t As Long
Dim fl As Object 'File
For Each fl In fld.Files
If fl.Name Like Mask Then
t = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
'Debug.Print fld.Path & "" & fl.Name
If Sheets(1).Cells(1, 1) = "" Then
Sheets(1).Cells(1, 1) = fld.Path & "\" & fl.Name
Else
Sheets(1).Cells(t, 1) = fld.Path & "\" & fl.Name
End If
End If
Next
End Sub
I want to sum the same range of values (say B3:B292) in 120 worksheets such that: ΣB3, ΣB4, ΣB5 ...... ΣB292.
I am not getting an error for the below VBA code, but it's also not returning any values.
Sub FAggreg1PNFAWO()
Dim Aggreg1PNFAWO As Workbook
Dim WS_Count As Integer
Dim filePath As String
Dim i As Integer
Dim TotalNp As Variant
filePath = "Directory"
Set Aggreg1PNFAWO = Workbooks.Open(filePath, ReadOnly:=True)
WS_Count = Aggreg1PNFAWO.Worksheets.Count
For i = 1 To WS_Count
'Sheets(i).range("B3:B292") <> "" And
If IsNumeric(Sheets(i).range("B3:B292")) Then
TotalNp = TotalNp + Sheets(i).range("B3:B292")
End If
Next
ActiveWorkbook.Close
ThisWorkbook.Activate
ActiveSheet.range("T4:T293").Value = TotalNp
End Sub
In that case try this:
Sub FAggreg1PNFAWO()
Dim Aggreg1PNFAWO As Workbook, myWB As Workbook
Dim WS_Count As Integer, i As Integer
Dim filePath As String
Dim TotalNp As Variant
Set myWB = ActiveWorkbook
filePath = "Directory"
Set Aggreg1PNFAWO = Workbooks.Open(filePath, ReadOnly:=True)
WS_Count = Aggreg1PNFAWO.Worksheets.Count
For X = 3 To 292
For i = 1 To WS_Count
If IsNumeric(Sheets(i).Range("B" & X)) Then
TotalNp = TotalNp + Sheets(i).Range("B" & X).Value
End If
Next
myWB.Activate
myWB.ActiveSheet.Range("T" & i + 1).Value = TotalNp
TotalNp = 0
Aggreg1PNFAWO.Activate
Next X
End Sub
Here you can use SUM function to do this. In the below answer am assuming B293 cell as empty and using it for summation. If you have some data in that cell then pick some other empty cell then try this.
Sub Sum()
Dim Project1P As Workbook
Dim WS_Count As Integer
Dim i As Integer
Dim V As Variant
Set Project1P = Workbooks.Open("C:\Users\Nandan\Desktop\SO\SO1.xlsx")
WS_Count = Project1P.Worksheets.Count
sumrange (WS_Count)
End Sub
Function sumrange(TotalSheets As Integer)
Dim reserves As Variant
For i = 1 To TotalSheets
Sheets(i).range("B" & 293).Formula = "=SUM(B3:B292)"
Next
For i = 1 To TotalSheets
reserves = reserves + Sheets(i).range("B" & 293)
Next
For i = 1 To TotalSheets
Sheets(i).range("B" & 293).Clear
Next
MsgBox "Total of all sheets :" & reserves
End Function
I'm trying to add a new excel for each time a button is clicked, since the sheet is named after the date. However, I get an error that says "Cannot rename a sheet to the same name as another sheet, a referenced object library or a workbook refernced by Visual basic."
Dim szTodayDate As String
szTodayDate = Format(Date, "mm.dd")
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = szTodayDate
What I want is to create a new worksheet that will be named mm.dd.i. While i refers to the number of time I create a new worksheet using the button. Sorry, I'm a VBA newbie.
Thank you for the answers. Gary's Student Made the most efficient one. Solved.
How about:
Sub sjvyv()
Dim szTodayDate As String
szTodayDate = Format(Date, "mm.dd")
Dim ws As Worksheet, i As Long
ReDim N(1 To Sheets.Count)
i = 1
For Each ws In Sheets
If Left(ws.Name, 5) = szTodayDate Then
N(i) = Mid(wsname, 6)
i = i + 1
End If
Next ws
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = szTodayDate & "." & i
End Sub
Here is a snippet that creates a new name for the sheet, that is available:
Sub AddSheet()
Dim TodayDate As String
Dim i As Integer
TodayDate = Format(Date, "mm.dd")
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
i = 1
Do While Not SheetNameAvailable(TodayDate & "." & i)
i = i + 1
Loop
ws.Name = TodayDate & "." & i
End Sub
Function SheetNameAvailable(SheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Err.Clear
Set ws = ThisWorkbook.Worksheets(SheetName)
SheetNameAvailable = (Err.Number <> 0)
On Error GoTo 0
End Function
On Error Resume Next
Set tempWS = Sheets(szTodayDate)
ws.Name = szTodayDate & IIf(tempWS Is Nothing, "", GetSheetCount(szTodayDate))
Set tempWS = Nothing
On Error GoTo 0
Function GetSheetCount(dateToTest) As Integer
Dim i As Integer
i = 1
For Each sh In ThisWorkbook.Sheets
If sh.Name Like dateToTest & "*" Then
i = i + 1
End If
Next
GetSheetCount = i
End Function
ws.Name = szTodayDate & ThisWorkbook.Sheets.Count + 1
Just append the count of sheets (+1) to the end.
I get a
Type Mismatch Error "13"
with the below code. Can anyone assist with where I'm going wrong with my VBA syntax and use of variables.
If Application.WorksheetFuntion.CountIf(Target, r.Value) > 1 Then
I've tried the matchFoundIndex code method to no success...Likely due to incorrect VBA syntax.
The intent of the CountIf line is to look for duplicates in column A. The rest of the code loops through files and worksheets copying the file name, worksheet name, and cell C1 for further analysis. I am a novice at coding and I'm sure there may be Dimmed variables that I'm not using, other formatting, and errors that I have not found yet. Any Help would be appreciative.
Sub CopyFileAndStudyName()
Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean
sPath = "C:\Users\mypath\"
' which row to begin writing to in the activesheet
lngRow = 2
SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False
If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub
Do While SName <> ""
lngwsh = 1
' Will cycle through all .xlsx files in sPath
Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D
For lngwsh = 1 To 3
Set sh = ActiveSheet
sh.Cells(lngRow, "A") = xlWB.Name
sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name
Dim Target As Range
Dim r As Range
Dim lastRow As Long
Dim ws As Worksheet
Set ws = xlWB.Worksheets(lngwsh)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Target = ws.Range("A1:A" & lastRow)
End With
For Each r In Target
If r.Value <> "" Then
If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
FindDuplicates = True
Exit For
Else
FindDuplicates = False
End If
End If
Next r
Debug.Print FindDuplicates
IsDup = FindDuplicates
sh.Cells(lngRow, "D") = IsDup
FindDuplicates = False
End If
lngRow = lngRow + 1
Next lngwsh
xlWB.Close False
xlApp.Quit
SName = Dir()
Loop
MsgBox "Report Ready!"
End Sub
If you want to check for Duplicates in a Range, you can use a Dictionary object.
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
For Each r In Target
If Trim(r.Value) <> "" Then
If Not Dict.exists(r.Value) Then ' not found in dictionary >> add Key
Dict.Add r.Value, r.Value
FindDuplicates = False
Else ' found in Dictionary >> Exit
FindDuplicates = True
Exit For
nd If
End If
Next r
Sub CopyFileAndStudyName()
Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean
sPath = "C:\Users\mypath\"
' which row to begin writing to in the activesheet
lngRow = 2
SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False
If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub
Do While SName <> ""
lngwsh = 1
' Will cycle through all .xlsx files in sPath
Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D
For lngwsh = 1 To 3
Set sh = ActiveSheet
sh.Cells(lngRow, "A") = xlWB.Name
sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name
Dim Target As Range
Dim r As Range
Dim lastRow As Long
Dim ws As Worksheet
Set ws = xlWB.Worksheets(lngwsh)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Target = ws.Range("A1:A" & lastRow)
End With
For Each r In Target
If r.Value <> "" Then
If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
FindDuplicates = True
Exit For
Else
FindDuplicates = False
End If
End If
Next r
Debug.Print FindDuplicates
IsDup = FindDuplicates
sh.Cells(lngRow, "D") = IsDup
FindDuplicates = False
lngRow = lngRow + 1
Next lngwsh
xlWB.Close False
xlApp.Quit
SName = Dir()
Loop
MsgBox "Report Ready!"
End Sub
I was having a similar experience using CountIF and passing it a range. In my case I was using:
i = Application.WorksheetFunction.CountIf(ws.UsedRange, r.Value)
which was giving me a Type Mismatch error. I had seen other people having success with the first parameter wrapped in Range() so after a few tries I found out that this would work:
i = Application.WorksheetFunction.CountIf(Range(ws.UsedRange.Address), r.Value)
So, I suggest that you change your code to this and see if it works:
If Application.WorksheetFuntion.CountIf(Range(Target.Address), r.Value) > 1 Then