I have this code so far to transfer between two files. How do I check whether the destination workbook is open? I've tried IsWorkbookOpen(), but it says "function not defined".
Sub Test2()
Dim rowCount As Long
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim a As Integer
a = 1
z = 5
x = 2
y = 16
ActiveWorkbook.Sheets("Results").Activate
rowCount = Cells(Rows.Count, "B").End(xlUp).Row
MsgBox "There are " & Workbooks.Count & " open workbooks!"
For Counter1 = 1 To 8
a = 1
z = 5
MsgBox "From :(" & a & "," & x & ") To:(" & z & "," & y & ")"
For Counter = 1 To rowCount
If IsWorkbookOpen("CMK & CPK Sheet (Rev2)") = True Then
MsgBox "Workbook is Open!"
Else
MsgBox "Workboook is Not Open!"
Workbooks("CMK & CPK Sheet (Rev2)").Sheets(3).Cells(z, y).Value = ActiveWorkbook.ActiveSheet.Cells(a, x).Value
z = z + 1
a = a + 1
Next Counter
y = y + 1
x = x + 1
Next Counter1
End Sub
Here is one way to see if a specific workbook is open:
Sub hfskadjrufc()
Dim bk As Workbook
Dim s As String, ItIsOpen As Boolean
s = "todo.xls"
ItIsOpen = False
For Each bk In Workbooks
If bk.Name = s Then
ItIsOpen = True
End If
Next bk
MsgBox ItIsOpen
End Sub
Try this:
Dim targetWB as Workbook
On Error Resume Next
Set targetWB = Workbooks("CMK & CPK Sheet (Rev2)")
On Error Goto 0
If targetWb Is Nothing Then
MsgBox "Workbook not yet open"
Exit Sub 'you can terminate procedure or you can use Workbooks.Open
Else
MsgBox "Workbook open"
'~~> rest of your code here
End If
Hope this helps.
Related
I just started working with VBA.
I have a VBA code that counts the number of the occurence of words inside the excel file. It works fine.
I want to run this VBA macro on all files I have inside a specific folder.
Could you help me out?
My code below:
I am getting values right only for the file from which I ran the macro. For the rest of the files, the reults obtained are wrong
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
Dim wordList As New Collection
Dim keyList As New Collection
Dim c
Worksheets("Sheet1").Activate
Dim RangeToCheck As Range
Set RangeToCheck = Range("A1:A1000")
For Each c In RangeToCheck
Dim words As Variant
words = Split(c, " ")
For Each w In words
Dim temp
temp = -1
On Error Resume Next
temp = wordList(w)
On Error GoTo 0
If temp = -1 Then
wordList.Add 1, Key:=w
keyList.Add w, Key:=w
Else
wordList.Remove (w)
keyList.Remove (w)
wordList.Add temp + 1, w
keyList.Add w, Key:=w
End If
Next w
Next c
Dim x
Dim k
k = 1
For x = 1 To wordList.Count
With Sheets("Sheet1")
.Cells(k, "E").Value = keyList(x)
.Cells(k, "F").Value = wordList(x)
k = k + 1
End If
End With
Next x
End With
xFileName = Dir
Loop
End If
End Sub
Try this
Public Sub LoopThroughFiles()
Dim xFd As FileDialog
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
xFd.AllowMultiSelect = False
If xFd.Show <> -1 Then
MsgBox "No Folder selected": Exit Sub
End If
Dim Folder As String: Folder = xFd.SelectedItems(1) & "\"
Dim Files
Files = Dir(Folder & "*.xls*")
Dim Xls As String
On Error Resume Next
Dim CrWB As Workbook, CrSheet As Worksheet
Dim ClnW As New Collection, ClnC As New Collection
Dim Cols As Integer: Cols = 1
Do While Files <> ""
Xls = Replace(Folder & Files, "\\", "\")
Set CrWB = Application.Workbooks.Open(Xls, , True)
Set CrSheet = CrWB.Sheets("Sheet1")
If Err.Number > 0 Then
MsgBox "Can't open File " & Xls & vbCrLf & Err.Description
Err.Clear
GoTo 1
End If
Dim c As Range
Set ClnW = New Collection: Set ClnC = New Collection
For Each c In CrSheet.Range("A1:A1000")
If c.Value <> "" Then
Words = Split(CStr(c.Value), " ", , vbTextCompare)
For Each s In Words
Err.Clear
tmp = ClnW(s)
If Err.Number > 0 Then
ClnW.Add Item:=s, Key:=s
ClnC.Add Item:=1, Key:=s
Else
x = ClnC(s) + 1
ClnC.Remove s
ClnC.Add Item:=x, Key:=s
End If
Next
End If
Next
Set CrSheet = ThisWorkbook.Sheets("Sheet1")
With CrSheet
.Cells(1, Cols).Value = Files
.Cells(2, Cols).Value = "Word"
.Cells(2, Cols + 1).Value = "Occurance"
.Range(.Cells(1, Cols), .Cells(1, Cols + 1)).Merge
Dim I As Integer: I = 3
For Each s In ClnW
.Cells(I, Cols).Value = s
.Cells(I, Cols + 1).Value = ClnC(s)
I = I + 1
Next
End With
Cols = Cols + 2
1
CrWB.Close False
Files = Dir()
Err.Clear
Loop
End Sub
I am struggling with an interesting problem that I have never experienced before and cannot seem to find any information about online. Here is the setup:
I am looping through a set of rows in a table - each row has a column for sheet name and a link from which I want to webscrape some data. I have written VBA code which loops through each row, creates a new sheet with the correct name, creates a querytable in that sheet, web scrapes the correct link and deletes the querytable.
Here is the code:
Sub WQ_Refresh(wsname As String, wqName As String, wqURL As String, strFC As String)
Dim ws As Worksheet
Dim wq As QueryTable
Dim errno As Long
Dim loopcnt As Integer
Dim refreshTime As Double
Dim lastrow As Long
refreshTime = Timer
Application.StatusBar = "Now downloading " & wqName & " for " & strFC
If wsname = "" Then Exit Sub
Set ws = ThisWorkbook.Sheets(wsname)
If ws.QueryTables.Count > 0 Then
Set wq = ws.QueryTables(1)
wq.Delete
End If
lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
If lastrow > 1 Then lastrow = lastrow + 1
Set wq = ws.QueryTables.Add(Connection:="URL;" & wqURL, Destination:=ws.Range("A" & lastrow))
errno = 1
loopcnt = 0
Do While Not (errno = 0 And loopcnt < 10)
On Error Resume Next
With wq
.FieldNames = True
.WebFormatting = xlWebFormattingNone
.WebSelectionType = xlAllTables
.Refresh BackgroundQuery:=False
.Delete
End With
loopcnt = loopcnt + 1
errno = Err.Number
If loopcnt = 10 Then HashtagFail wqName
On Error GoTo 0
Loop
If lastrow > 1 Then
ws.Rows(lastrow - 1 & ":" & lastrow).Delete
End If
Set wq = Nothing
Application.StatusBar = "Downloaded " & wqName & " in " & Round(Timer - refreshTime, 0) & " seconds"
For some reason that I cannot understand, the wq.Delete function will correctly delete the created wq but it will also remove a connection in another sheet which is set up manually as part of the file.
To be clear - it does not DELETE the connection. It is still there but if you look at its properties, and go to the Used In tab, it shows as no longer used in any sheet.
I have no idea why this is happening - for me, the code should clearly delete only the connection in the sheet in the loop and not impact any other connections in the file.
This seems like a fundamental excel bug but I'd really like any input you have because I'm completely stuck.
Appreciate your help!
Based on the comment form #DeanDeVilliers The solution that worked was to reference the table by name. Here is the working code if anyone is curious
Sub WQ_Refresh(wsname As String, wqName As String, wqURL As String, strFC As String)
Dim ws As Worksheet
Dim wq As QueryTable
Dim errno As Long
Dim loopcnt As Integer
Dim refreshTime As Double
Dim lastrow As Long
refreshTime = Timer
Application.StatusBar = "Now downloading " & wqName & " for " & strFC
If wsname = "" Then Exit Sub
Set ws = ThisWorkbook.Sheets(wsname)
If ws.QueryTables.Count > 0 Then ws.QueryTables("WQ_" & wqName).Delete
lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
If lastrow > 1 Then lastrow = lastrow + 1
Set wq = ws.QueryTables.Add(Connection:="URL;" & wqURL, Destination:=ws.Range("A" & lastrow))
errno = 1
loopcnt = 0
Do While Not (errno = 0 And loopcnt < 10)
On Error Resume Next
With wq
.FieldNames = True
.WebFormatting = xlWebFormattingNone
.WebSelectionType = xlAllTables
.Refresh BackgroundQuery:=False
.Name = "WQ_" & wqName
' .Delete
End With
loopcnt = loopcnt + 1
errno = Err.Number
If loopcnt = 10 Then HashtagFail wqName
On Error GoTo 0
ws.QueryTables("WQ_" & wqName).Delete
Loop
If lastrow > 1 Then
ws.Rows(lastrow - 1 & ":" & lastrow).Delete
End If
Set wq = Nothing
Application.StatusBar = "Downloaded " & wqName & " in " & Round(Timer - refreshTime, 0) & " seconds"
End Sub
I have several workbooks that contain 3,500+ named ranges, most of which are not used. To clean up the mess, I would like to run a macro that deletes any unused names.
The following macro seems to work, but it takes about half an hour to run. I actually turned on the status bar so I could be sure it was still progressing.
I would like to get advice on how to accomplish this task more efficiently.
Sub DeleteUnusedNames()
'PURPOSE: Delete named ranges that are not used in formulas in the active workbook
Dim xWB As Workbook: Set xWB = ActiveWorkbook
Dim xWS As Worksheet
Dim xNameCount As Long 'Count of all named ranges
Dim xCount As Long 'Count of current range - used to track progress
Dim xFound As Long 'Count of times a named range was used in a formula - moves on to next code when > 0
Dim xDeletedCount As Long
Dim xName As Name
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
xNameCount = xWB.Names.count
For Each xName In xWB.Names
If xName.Name Like "*Print_*" Then 'Skip Print Areas and Print Titles
Else
xFound = 0
xCount = xCount + 1
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")"
For Each xWS In xWB.Worksheets
If xWS.Name Like "Workbook Properties" Then 'Don't search the Workbook Properties tab for Names (if this tab exists, it will not have any used names)
Else
xFound = xFound + xWS.UsedRange.Find(What:=xName.Name, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False).count
If xFound > 0 Then Exit For 'Name was found. Stop looking.
End If
Next xWS
If xFound = 0 Then 'Name was not found in a formula on any of the worksheets
xName.Delete
xDeletedCount = xDeletedCount + 1
End If
End If
Next xName
If xMsg = "" Then
MsgBox "No unused names were found in the workbook", , "No named ranges were deleted"
Else
MsgBox xDeletedCount & " names were deleted", , "Unused named ranges were deleted"
End If
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
As commented above, please give this a try.
Is putting all the formulas in arrays rather than named ranges.
Sub DeleteUnusedNames()
'PURPOSE: Delete named ranges that are not used in formulas in the active workbook
Dim xWB As Workbook: Set xWB = ActiveWorkbook
Dim xWS As Worksheet
Dim xNameCount As Long 'Count of all named ranges
Dim xCount As Long 'Count of current range - used to track progress
Dim xFound As Long 'Count of times a named range was used in a formula - moves on to next code when > 0
Dim xDeletedCount As Long
Dim xName As Name
Dim arrData As Variant 'an array to hold all formulas
Dim R As Long, C As Long 'rows/columns
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
xNameCount = xWB.Names.Count
For Each xName In xWB.Names
If xName.Name Like "*Print_*" Then 'Skip Print Areas and Print Titles
Else
xFound = 0
xCount = xCount + 1
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")"
For Each xWS In xWB.Worksheets
If xWS.Name Like "Workbook Properties" Then 'Don't search the Workbook Properties tab for Names (if this tab exists, it will not have any used names)
Else
arrData = xWS.UsedRange.Formula
For R = LBound(arrData) To UBound(arrData)
For C = LBound(arrData, 2) To UBound(arrData, 2)
If InStr(1, arrData(R, C), xName.Name) > 0 Then
xFound = 1
Exit For
End If
Next C
If xFound > 0 Then Exit For
Next R
End If
Next xWS
If xFound = 0 Then 'Name was not found in a formula on any of the worksheets
xName.Delete
xDeletedCount = xDeletedCount + 1
End If
End If
Next xName
If xMsg = "" Then
MsgBox "No unused names were found in the workbook", , "No named ranges were deleted"
Else
MsgBox xDeletedCount & " names were deleted", , "Unused named ranges were deleted"
End If
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Could replace that loop with the below, should hold all data (... well, hopefully). If all the usedranges load successfully, then it should be a breeze to loop through everything.
Dim Z As Long
Dim arrWholeData() As Variant: ReDim arrWholeData(xWB.Worksheets.Count)
For Z = 1 To xWB.Worksheets.Count
arrWholeData(Z) = xWB.Worksheets(Z).UsedRange.Formula
Next Z
For Each xName In xWB.Names
If xName.Name Like "*Print_*" Then 'Skip Print Areas and Print Titles
Else
xFound = 0
xCount = xCount + 1
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")"
For Z = 1 To xWB.Worksheets.Count
For R = LBound(arrWholeData(Z)) To UBound(arrWholeData(Z))
For C = LBound(arrWholeData(Z), 2) To UBound(arrWholeData(Z), 2)
If InStr(1, arrWholeData(Z)(R, C), xName.Name) > 0 Then
xFound = 1
Exit For
End If
Next C
If xFound > 0 Then Exit For
Next R
If xFound > 0 Then Exit For
Next Z
If xFound = 0 Then 'Name was not found in a formula on any of the worksheets
xName.Delete
xDeletedCount = xDeletedCount + 1
End If
End If
Next xName
EDIT: added an alternative.
EDIT: FINAL COMPLETE CODE:
Sub DeleteUnusedNames()
'PURPOSE: Delete named ranges that are not used in formulas in the active workbook
Dim startTime As Single, endTime As Single
startTime = Timer
Dim xWB As Workbook: Set xWB = ActiveWorkbook
Dim xNameCount As Long: xNameCount = xWB.Names.count
Dim xCount As Long 'Count of current range - used to track progress
Dim xFound As Long 'Count of times a named range was used in a formula - moves on to next code when > 0
Dim xDeleted As Long 'Count of deleted named ranges
Dim xArrWholeData() As Variant: ReDim xArrWholeData(xWB.Worksheets.count)
Dim xRow As Long 'Row number
Dim xCol As Long 'Column number
Dim xName As Name 'Used for looping through names
Dim xWSNum As Long 'Used for looping through worksheets
Dim xNName As String 'Name of current named range in the loop - used for comparing
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
For xWSNum = 1 To xWB.Worksheets.count
xArrWholeData(xWSNum) = xWB.Worksheets(xWSNum).UsedRange.Formula
Next xWSNum
For Each xName In xWB.Names
xNName = xName.Name
xCount = xCount + 1
If xCount Mod 50 = 0 Then
endTime = Timer
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ") " & (endTime - startTime) & " seconds have passed"
End If
If xNName Like "*Print_*" Then 'Skip Print Areas and Print Titles
Else
xFound = 0
For xWSNum = 1 To xWB.Worksheets.count
If xWB.Worksheets(xWSNum).Name Like "Workbook Properties" Then 'Skip the Workbook Properties worksheet
Else
For xRow = LBound(xArrWholeData(xWSNum)) To UBound(xArrWholeData(xWSNum))
For xCol = LBound(xArrWholeData(xWSNum), 2) To UBound(xArrWholeData(xWSNum), 2)
If InStr(1, xArrWholeData(xWSNum)(xRow, xCol), xNName) > 0 Then
xFound = 1 'Name was found
GoTo NextName 'Stop looking for this name and go to the next name
End If
Next xCol
Next xRow
End If
Next xWSNum
If xFound = 0 Then 'Name was not found in a formula on any of the worksheets
xDeleted = xDeleted + 1
xName.Delete
End If
End If
NextName:
Next xName
endTime = Timer
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ") " & (endTime - startTime) & " seconds have passed"
If xDeleted = 0 Then
MsgBox "No unused names were found in the workbook", , "No named ranges were deleted"
Else
MsgBox xDeleted & " names were deleted:", , "Unused named ranges were deleted" 'Removed & vbCr & xMsg before the first comma
End If
Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Another alternative could be to check if the name range has any dependents :
Function HasDependents(r As Range)
r.ShowDependents
HasDependents = r.Address(, , , 1) <> r.NavigateArrow(0, 1).Address(, , , 1)
r.ShowDependents 1
End Function
Sample use :
For Each xName In xWB.Names
If Not HasDependents(xName.RefersToRange) Then xName.Delete
Next
Technically, this does not check if the name is used, but only if the range the name refers to is used (assuming all names refer to range).
To go through the dependents and check if their formulas contain the name, this sample can be modified :
https://excelhelphq.com/how-to-find-all-dependent-cells-outside-of-worksheet-and-workbook-in-excel-vba/
I'm trying to execute a macro from a new worksheet with a button so that it runs in another worksheet (named "ARF Export").
Unfortunately I don't know how to set the worksheet I want the macro to run in to ("ARF Export"). Please could you advise me on how to proceed?
The error I get when I run this code in a different sheet is:
Error 3265 Item cannot be found in the collection corresponding to the requested name or ordinal in procedure export_data
When I step into Debug I don't get an error until the end but it skips through my For Loop on line 38 next i
for x = 2 To nextrow
DatabaseData.AddNew
For i = 1 To 35
DatabaseData(Cells(1, i).Value) = Worksheets("ARF Export").Cells(x, i).Value
Next i
DatabaseData.Update
Next x
All code below---
Option Explicit
Sub CopyDatatoAccess()
Dim DatabaseConn As ADODB.Connection
Dim DatabaseData As ADODB.Recordset
Dim Pathway
Dim x As Long, i As Long
Dim nextrow As Long
On Error GoTo errorhandler:
Pathway = Worksheets("ARF Export").Range("AR2").Value
nextrow = Worksheets("ARF Export").Range("As2").Value
Set DatabaseConn = New ADODB.Connection
If Worksheets("ARF Export").Range("A2").Value = "" Then
MsgBox "ARF form is not present for Upload"
Exit Sub
End If
DatabaseConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Pathway
Set DatabaseData = New ADODB.Recordset
DatabaseData.Open Source:="ARFs", _
ActiveConnection:=DatabaseConn, _
CursorType:=adOpenDynamic, _
LockType:=adLockOptimistic, _
Options:=adCmdTable
For x = 2 To nextrow
DatabaseData.AddNew
For i = 1 To 35
DatabaseData(Cells(1, i).Value) = Worksheets("ARF Export").Cells(x, i).Value
Next i
DatabaseData.Update
Next x
DatabaseData.Close
DatabaseConn.Close
Set DatabaseData = Nothing
Set DatabaseConn = Nothing
MsgBox "The ARF is now uploaded"
Application.ScreenUpdating = True
Worksheets("ARF Export").Cells.Range("AK2").Value = Worksheets("ARF Export").Cells.Range("AK4").Value
Worksheets("ARF Export").Cells.Range("AK5").Value = Worksheets("ARF Export").Cells.Range("AK4").Value + 1
On Error GoTo 0
Exit Sub
errorhandler:
Set DatabaseData = Nothing
Set DatabaseConn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
End Sub
Thanks for the help
-Turns out I needed to reference DatabaseData(Cells(1, i).Value) once i did this
For x = 2 To nextrow
DatabaseData.AddNew
For i = 1 To 35
DatabaseData(Worksheets("ARF Export").Cells(1, i).Value) = Worksheets("ARF Export").Cells(x, i).Value
Next i
DatabaseData.Update
Next x
It worked great. Thank you for your help all!
I try to merge multiple Excel file in to one master sheet.
The code below works perfect because is not duplicating the merged data. My only issue is that is copying also the formulas from other file ... what I need is only the values.
I try to change some part of the code to
PasteSpecial Paste:=xlPasteValues
Error Image
Error 400 Image
Than I get an error (.
Code Used:
Sub sumit()
Dim fso As New FileSystemObject
Dim NoOfFiles As Double
Dim counter As Integer
Dim r_counter As Integer
Dim s As String
Dim listfiles As Files
Dim newfile As Worksheet
Dim mainworkbook As Workbook
Dim combinedworksheet As Worksheet
Dim tempworkbook As Workbook
Dim rowcounter As Double
Dim rowpasted As Integer
Dim delHeaderRow As Integer
Dim Folderpath As Variant
Dim headerset As Variant
Dim Actualrowcount As Double
Dim x As Long
Dim Delete_Remove_Blank_Rows As String
Range("A:A").Clear
Range("B:B").Clear
Range("C:C").Clear
Folderpath = ActiveWorkbook.Sheets(2).Range("I7").Value
headerset = ActiveWorkbook.Sheets(2).Range("F4").Value
Delete_Remove_Blank_Rows = ActiveWorkbook.Sheets(2).Range("F3").Value
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Dim Files_Count_No_Of_Rows_In_Sheets(1000) As Double 'declare the array of the size of no of files in the folder
Set listfiles = fso.GetFolder(Folderpath).Files
counter = 0
r_counter = 1
rowcounter = 1
Actualrowcount = 0
For Each fls In listfiles
counter = counter + 1
Range("A" & counter).Value = fls.Name
Next
'MsgBox ("count of files in folder is " & NoOfFiles)
Set mainworkbook = ActiveWorkbook
Set combinedworksheet = mainworkbook.Sheets(2)
mainworkbook.Sheets(3).UsedRange.Clear
'MsgBox ("Sheet is clear for the data to be copied")
For i = 1 To NoOfFiles
mainworkbook.Sheets("Combine").Activate
'MsgBox ("Sheet 3 is Activated")
mainworkbook.Sheets("Combine").Range("A" & rowcounter).Select
Application.Workbooks.Open (Folderpath & "\" & Range("A" & i).Value)
Set tempworkbook = ActiveWorkbook
Set newfile = ActiveSheet
rowpasted = rowcounter
'MsgBox ("pointer at " & rowpasted)
newfile.UsedRange.Copy
'MsgBox ("Data is copied")
mainworkbook.Sheets(3).Paste
'MsgBox ("Data is pasted successfully")
'MsgBox ("Blank rows has been deleted " & Remove_Blank_Rows & " " & headerset)
If Delete_Remove_Blank_Rows = "Yes" Then
'If Remove_Blank_Rows = Yes Then
'MsgBox ("Blank rows has been deleted" & Delete_Remove_Blank_Rows)
For x = mainworkbook.Sheets("Combine").Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
If WorksheetFunction.CountA(mainworkbook.Sheets("Combine").Rows(x)) = 0 Then
mainworkbook.Sheets("Combine").Rows(x).Delete
'MsgBox ("Blank rows has been deleted" & Remove_Blank_Rows)
End If
Next
End If
rowcounter = mainworkbook.Sheets(3).UsedRange.Rows.Count + 1
'MsgBox ("row counter is updated" & rowcounter)
rowpasted = rowcounter - rowpasted
'MsgBox ("No fo rows pasted" & rowpasted)
delHeaderRow = rowcounter - rowpasted
'MsgBox ("Which row to delete" & delHeaderRow)
'MsgBox ("Pointer at row beforw deletion" & rowpasted)
If headerset = "Yes" Or headerset = "YES" Or headerset = "yes" Then
If delHeaderRow <> 1 Then
mainworkbook.Sheets(3).Rows(delHeaderRow).EntireRow.Delete
rowcounter = rowcounter - 1
rowpasted = rowpasted - 1
Else
End If
Else
End If
'MsgBox ("Header deleted")
'MsgBox ("row counter is updated" & rowcounter)
combinedworksheet.UsedRange.ClearOutline
'combinedworksheet.
tempworkbook.Close
'MsgBox ("no of rows are abt to get pasted in sheet 1")
Files_Count_No_Of_Rows_In_Sheets(i) = rowpasted
Actualrowcount = Actualrowcount + rowpasted
Next i
mainworkbook.Sheets(1).UsedRange.ClearContents
For Each fls In listfiles
r_counter = r_counter + 1
mainworkbook.Sheets(1).Range("A" & r_counter).Value = fls.Name
mainworkbook.Sheets(1).Range("B" & r_counter).Value = Files_Count_No_Of_Rows_In_Sheets(r_counter - 1)
mainworkbook.Sheets(1).Range("A" & r_counter, "B" & r_counter).Borders.Value = 1
Next
mainworkbook.Sheets(1).Range("B" & r_counter + 1).Interior.ColorIndex = 46
mainworkbook.Sheets(1).Range("B" & r_counter + 1).Value = Actualrowcount
mainworkbook.Sheets(1).Range("B" & r_counter + 1).Borders.Value = 1
mainworkbook.Sheets(1).Range("A1", "B1").Interior.ColorIndex = 46
mainworkbook.Sheets(1).Range("A1", "B1").Borders.Value = 1
mainworkbook.Sheets(1).Range("A1").Value = "Files List"
mainworkbook.Sheets(1).Range("B1").Value = "No Of Rows"
MsgBox ("List of Files are Availabe in sheet 1..Total " & NoOfFiles & " Files Combiled")
End Sub
In the error image there is mainworkbook.Sheets(3).Paste xlPasteValues which is wrong and should be mainworkbook.Sheets(3).Cells(rowcounter, 1).PasteSpecial xlPasteValues.