Excel to Access import false columns - vba

I'm dealing with a lot of historical data and I made a macro to format these excel spreadsheets into an Access friendly information. However I'm having issues when importing these excel files into Access. No matter what I code into the VBA, Access still believes there are about 30 blank columns after the first four of actual data. The only way to prevent this is to manually go in and delete the columns. For some reason my VBA code just won't prevent it. I'm dealing with a lot of spreadsheets, so it's going to take considerable time to manually delete these columns. My code is below; any ideas on how I could make Access interpret these correctly?
Public CU_Name As String
Sub RegulatorFormat()
Dim wks As Worksheet
Dim wks2 As Worksheet
Dim iCol As Long
Dim lastRow As Long
Dim Desc As Range
Dim lastCol As Long
Application.ScreenUpdating = False
Worksheets.Select
Cells.Select
Selection.ClearFormats
Call FormulaBeGone
ActiveSheet.Cells.Unmerge
CU_Name = [B1].Value
lastRow = Range("C" & Rows.Count).End(xlUp).Row
Set Desc = Range("A1", "A57")
Desc.Select
For Each wks In ActiveWindow.SelectedSheets
With wks
On Error Resume Next
For iCol = 16 To 4 Step -1
Dim PerCol As Date
PerCol = Cells(1, iCol)
.Columns(iCol).Insert
Range(Cells(1, iCol), Cells(lastRow, iCol)) = CU_Name
.Columns(iCol).Insert
Range(Cells(1, iCol), Cells(lastRow, iCol)) = Desc.Value
.Columns(iCol).Insert
Cells(1, iCol).Value = PerCol
Range(Cells(1, iCol), Cells(lastRow, iCol)) = Cells(1, iCol)
Range(Cells(1, iCol), Cells(lastRow, iCol)).NumberFormat = "mm/dd/yyyy"
Next iCol
End With
Next wks
Rows("1:2").EntireRow.Delete
Columns("A:C").EntireColumn.Delete
lastCol = ws.Cells.Find(What:="*", _
After:=ws.Cells(1, 1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
For Each wks2 In ActiveWindow.SelectedSheets
With wks2
On Error Resume Next
For iCol = 52 To 6 Step -4
lastRow = Range("C" & Rows.Count).End(xlUp).Row
Set CutRange = Range(Cells(1, iCol), Cells(54, iCol - 3))
CutRange.Select
Selection.Cut
Range("A" & lastRow + 1).Select
ActiveSheet.Paste
Next iCol
End With
Next wks2
Columns("E:ZZ").Select
Selection.EntireColumn.Delete
Application.ScreenUpdating = True
Rows("1").Insert
[A1] = "Period"
[B1] = "Line#"
[C1] = "CU_Name"
[D1] = "Balance"
Columns("E:BM").Select
Selection.Delete Shift:=xlToLeft
Call Save
End Sub
Sub FormulaBeGone()
Worksheets.Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Select
Application.CutCopyMode = False
End Sub
Sub Save()
Dim newFile As String
newFile = CU_Name
ChDir ("W:\ALM\Statistics\MO Automation\2015")
'Save folder
ActiveWorkbook.SaveAs Filename:=newFile
'Later should seperate CU's into folder by province and year
End Sub

Access is importing the 'used range' as a table, and that's not quite the same as 'all the cells with data'.
The 'UsedRange' property picks up empty strings, formatting and (sometimes) live selections and named ranges...
...And it sometimes picks up an oversize used range for no reason anyone outside Redmond will ever know.
So your next job is to redefine the phrase 'Access-Friendly'
The most 'Access-Friendly' method of all is to export csv files - you may hear opinions to the contrary, but not from anyone who's done it often enough to encounter the memory leak in the JET OLEDB 4 Excel driver.
But the easiest way is to specify the range in a linked table or - better still - an ODBC-Connected SQL Query:
SELECT *
FROM [Sheet1$D3:E24]
IN "" [Excel 8.0;HDR=YES;IMEX=0;DATABASE=C:\Temp\Portfolio.xls];
Note the format for specifying a sheet and range: '$', not '!' to separate the sheet name and the address. You could use Sheet$, but you're back to the whole guess-the-used-range thing.
Note that I've said there's a header row, cells D3:E3, listing the field names 'HDR=YES'. You don't have to, but I do recommend it: calling columns by name is easier for the database engine.
Note that I've also specified 'IMEX=0', which ought to mean 'don't guess the field types, they are all text' but the JET database drivers treat it with cavalier disregard. So import this into a table with text columns and do your data type and format work in a subsequent MS-Access query on those text fields.
Those two quote marks after 'IN' ? Don't ask.
And I'm using an '.xls' file, Excel version 8.0. Look up ConnectionStrings.com for later versions, or build a linkled table in MS-Access to the type of file you want, and interrogate the Tabledef.Connect property.
It will have occurred to you by now that you can dynamically construct the query, supplying file names and sheet names for successive imports from a vast folder of spreadsheets; so here's the final piece of SQL, and the reason for specifying field names:
JET SQL for inserting rows directly into an MS-Access table from an Excel range:
INSERT INTO Table1 (Name, PX_Last, USD, Shares)
SELECT *
FROM [Sheet1$D3:E24]
IN "" [Excel 8.0;HDR=YES;IMEX=0;DATABASE=C:\Temp\Portfolio.xls];
This will run in the MS-Access database: don't try to execute it from an ADODB connection inside the spreadsheet files you're exporting.

Related

copy paste filtered data not working as expected

First things first. I am very new to VBA.
Secondly, I googled my ass of and I honestly don't get to the bottom of it. Mostly because the code is adapted to my needs based on googleing i did (copy/paste of code).
To my problem. I have a sheet(Raw Data) with lots of columns(A:AN) and lots of rows(160000) that gets updated every now and then. I want to filter the dataset based on the criteria from a few columns(A & B), and the copy/paste the data in a different sheet(Scatter Raw) starting from column A. I also do not want to copy the header from "Raw Data" and start pasting in "Scatter Sheet" also below the header -> in this case 2 rows.
I have two issues for now:
Based on the filters I do, I will get 17267 rows in "Raw Data". If I simply do a select and copy then I copy only the filtered data. But the moment I paste the data somehow I suddenly get 18362 rows, even though they are empty. I can see this by the fact that the scroll bar goes down. I used this way of copying because sometimes I want to be able to append the copied data based on value set in a different cell. What am I doing here wrong, or what is happening?
I have more sheets inside the workbook. If I do not have the Raw Data worksheet selected I get an error like "Application-defined or object-defined error" on the "Set rng = " line which I don't get. In other test I also got a different error, but that was because the Range was based on the active sheet and not the one I needed. Why is this happening, since the filters are correctly set?
The values from column N should all be divided by 1000. I guess I have no other way then using a temporary copy column, divide it by 1000 in a new column and then copy/paste the new values to the location I need in, right?
Just one last mention, the code is running in a Module and will be later assigned to a button.
Sub Copy()
Dim destTrSheet As Worksheet
Dim sctrSheet As Worksheet
Set destTrSheet = ThisWorkbook.Worksheets("Data Raw")
Set sctrSheet = ThisWorkbook.Worksheets("Scatter Raw")
With destTrSheet
.Range("A:A").AutoFilter field:=1, Criteria1:="VF", Operator:=xlFilterValues
.Range("B:B").AutoFilter field:=2, Criteria1:="CITY", Operator:=xlFilterValues
Set Rng = .Range("N2").Resize(Cells(Rows.count, "N").End(xlUp).Row - 1)
Rng.Copy
sctrSheet.Range("A" & Rows.count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
Set Rng = .Range("X2").Resize(Cells(Rows.count, "N").End(xlUp).Row - 1)
Rng.Copy
sctrSheet.Range("B" & Rows.count).End(xlUp).Offset(2, 0).PasteSpecial (xlPasteValues)
End With
End Sub
The issues you mentioned
Discrepancy between manual copy and code copy could be caused by the offsets used:
Col A .Offset(1, 0).PasteSpecial - 1 row below last used row
Col B .Offset(2, 0).PasteSpecial - 2 rows below last used row
The error is caused by .Range("N2") vs (Cells(Rows.count, "N")
.Range("N2") is explicitly qualified because of the dot (.) - refers to "Data Raw"
Cells(Rows.count, "N") is implicitly referring to ActiveSheet (missing .)
If column N should be divided by 1000
Yes, a helper column can be used, as in the code bellow
Another way: copy the column to an array, divide each value, then paste it back
If column N contains strings, the division will generate cell errors:
Option Explicit
Public Sub CopyRawToScatter()
Dim wsR As Worksheet: Set wsR = ThisWorkbook.Worksheets("Data Raw")
Dim wsS As Worksheet: Set wsS = ThisWorkbook.Worksheets("Scatter Raw")
Dim lrR As Long: lrR = wsR.Cells(wsR.Rows.Count, "A").End(xlUp).Row
Dim lrS As Long: lrS = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
With wsR
Dim fRng As Range: Set fRng = .Range(.Cells(1, "A"), .Cells(lrR, "B"))
Dim rngN As Range: Set rngN = .Range(.Cells(2, "N"), .Cells(lrR, "N"))
Dim rngX As Range: Set rngX = .Range(.Cells(2, "X"), .Cells(lrR, "X"))
Dim cRng As Range: Set cRng = Union(rngN, rngX)
End With
Application.ScreenUpdating = False
fRng.AutoFilter field:=1, Criteria1:="VF", Operator:=xlFilterValues
fRng.AutoFilter field:=2, Criteria1:="CITY", Operator:=xlFilterValues
If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then
cRng.Copy
wsS.Cells(lrS, "A").PasteSpecial xlPasteValues
With wsS
Dim vis As Long: vis = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim lcS As Long: lcS = .Cells(lrS, "A").End(xlToRight).Column + 1
Dim divA As Range: Set divA = .Range(.Cells(lrS, "A"), .Cells(vis, "A"))
Dim divX As Range: Set divX = .Range(.Cells(lrS, lcS), .Cells(vis, lcS))
divX.Formula = "=" & .Cells(lrS, 1).Address(RowAbsolute:=False) & " / 1000"
divA.Value2 = divX.Value2
divX.ClearContents
End With
End If
wsR.UsedRange.AutoFilter
Application.ScreenUpdating = False
End Sub
Other issues
Potential conflict between your Sub name (Copy()) with the built-in Range.Copy Method
The 2 AutoFilter lines are invalid
.Range("A:A").AutoFilter field:=1, Criteria1:="VF", Operator:=xlFilterValues
.Range("B:B").AutoFilter field:=2, Criteria1:="CITY", Operator:=xlFilterValues
If your code works you probably modified it when posting the question; they should be
.Range("A:B").AutoFilter field:=1, Criteria1:="VF", Operator:=xlFilterValues
.Range("A:B").AutoFilter field:=2, Criteria1:="CITY", Operator:=xlFilterValues
You don't need brackets for .PasteSpecial (xlPasteValues)

VBA: Different requirements when coding

This is a follow up question from a previous post.
So the company I work for has recently updated their Excel from 2003 to 2013. I am now having issues with some pretty basic VBA code. The line Cells.AutoFilter(x, y) in particular is giving me issues.
I wrote a very ugly program months ago which looks something like this:
...
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=11, Criteria1:= _
"0"
If wf.CountA(r) > 0 Then
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=8, Criteria1:= _
Array("baseunitprice", "burden", "MTLBURRATE", "PurPoint", "Vendornum"), Operator _
:=xlFilterValues
Range("K2:K50000").SpecialCells(xlCellTypeVisible).Select
ActiveCell.FormulaR1C1 = "MACROUSE"
Range(Selection, Selection.End(xlDown)).Select
Selection.FillDown
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=8
...
This is the first program I wrote and must be rewritten for obvious reasons.
In an attempt to mirror the above code in a more elegant, readable way, I created another Sub in the same module:
Sub ActualProgram()
Dim firstRow As Integer
Dim lastRow As Integer
Dim firstCol As Integer
Dim lastCol As Integer
Dim allRange As Range
Dim vRange As Range
Dim bRange As Range
Dim commentsCol As Integer
Dim commentsColRng As Range
Dim fieldNameCol As Integer
Dim userCol As Integer
If Cells(2, 1) <> "" Then
DeleteEmptyRows
firstCol = 1
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
firstRow = 2
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
commentsCol = Rows(1).find("Comments").Column '11
fieldNameCol = Rows(1).find("Field Name").Column '8
userCol = Rows(1).find("User").Column '4
Set allRange = Range(Cells(firstRow, firstCol), Cells(lastRow, lastCol))
Set commentsColRng = Range(Cells(firstRow, commentsCol), Cells(lastRow, commentsCol))
ActiveSheet.ListObjects("Table1").Range.AutoFilter 11, "0" 'WORKS
Cells.AutoFilter commentsCol, "0" 'FAILS
Call MarkFieldNames(fieldNameCol, commentsColRng)
Call MarkNonSMFields(commentsColRng)
Call TargetFieldNames(fieldNameCol, commentsCol)
End If
End Sub
This sub is never called in the previous program, of course. I just wanted to have both codes together so I could refer to the previous one while writing the new one.
The line I'm having issues with in the new code is
Cells.AutoFilter commentsCol, "0".
The line which I used in the old code is ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=11, Criteria1:="0"
The old code still works fine. The new one throws an AutoFilter method of Range class failed run-time error. In my eyes, these two lines do the exact same thing, and I've used the line Cells.AutoFilter(x, y) too many times to count without error on Excel 2013.
Is there a setting I need to change? I ask because I see in VBA > Tools > Options > Editor there are Code Settings options such as Require Variable Declaration, which leads me to belive that there may be a setting which disables the way I call the AutoFilter() method.
Thank you for your time.
I am working with a table. Hence ActiveSheet.ListObjects("Table1")... Tables are treated differently than regular cells, and therefore, must be specifically targeted when autofiltering.

Select and extract row of data to another sheet

I'm working with big worksheet containing stocks information, with columns organized like this :
ID DATE TIME PRICE QUANTITY NBE
It goes on for 500k+ rows, and I have 10+ sheets to go through. I need to extract only the first two trade of each trading day, and create a new list on a new sheet (Sheet1). The first trade of every day is always at "09:00:00".
So far I wrote this piece of code, in which I tried to copy the two lines I need and then paste them into Sheet1 thus creating the new list. It runs without errors, but nothing shows up...
Sub Macro1()
i = 2
Range("C2").Select
Range(Selection, Selection.End(xlDown)).Select
For Each Cell In Selection
If Day(.Range("B" & cRow).Value) <> Day(.Range("B" & cRow - 1).Value) Then
ActiveCell.EntireRow.Copy
ActiveWorkbook.Sheets("Sheet1").Rows(i).Paste
ActiveCell.Offset(1).Copy
ActiveWorkbook.Sheets("Sheet1").Rows(i + 1).Paste
i = i + 2
End If
Next Cell
End Sub
Shouldn't i select and the copy paste the two rows together? Or is it possible to create a range consisting of 2 rows and 6 columns from the activecell and then copy paste that range?
EDIT 1: It's not working.. I updated it like above, but I still get an error 438 here ActiveWorkbook.Sheets("Sheet1").Rows(i).Paste
EDIT 2: I'm def a big noob. Just realized not every first trade was made at 9:00:00 so i need to select the row based on wether or not one day have passed, and select the first two.
Can I use this condition instead : If Day(Range("B" & cRow).Value) <> Day(Range("B" & cRow - 1).Value) Then ?
I'm betting that your Time column is formatted as a Date/Time field, so you're comparing a string 09:00:00 to a long (date/time) and it's never going to be equal.
Try this:
if Format(Cell.Value, "hh:mm:ss") = "09:00:00" Then
And your English isn't bad at all...
This should do it quickly
make sure your on the sheet with data and run it, and it will copy it onto sheet1 in the same workbook starting at row2
you should make sure sheet1 is empty also , with .clearContents
Sub Macro1()
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim cRow As Long
Dim shSrc As Worksheet
Dim lngNextDestRow As Long
Dim shDest As Worksheet
Application.ScreenUpdating = False
Set shSrc = ActiveWorkbook.ActiveSheet
Set shDest = ActiveWorkbook.Sheets("Sheet1")
With shSrc
lngFirstRow = 2
lngLastRow = .Cells.Find(What:="*", After:=.Cells.Cells(1), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
lngNextDestRow = 2
For cRow = lngFirstRow To lngLastRow Step 1
If Format(.Range("C" & cRow).value, "hh:mm:ss") = "09:00:00" Then
.Rows(cRow).EntireRow.Copy Destination:=shDest.Range("A" & lngNextDestRow )
.Rows(cRow+1).EntireRow.Copy Destination:=shDest.Range("A" & lngNextDestRow+1 )
lngNextDestRow = lngNextDestRow + 2
End If
Next cRow
End With
Application.ScreenUpdating = True
End Sub
When you refrence a sheet using the following line
ActiveWorkbook.Sheets(Sheet1).Rows(i).Paste
Sheet1 is likely a variable that is not defined properly. If "Sheet1" is the actual name of the sheet then enclose it in doublequotes
ActiveWorkbook.Sheets("Sheet1").Rows(i).Paste
After looking at #FreeMan's answer....you should do that first. You'll probably get an error 9 subscript error after you fix what he said to do.

VBA: Selecting range by variables

I want to select the formatted range of an Excel sheet.
To define the last and first row I use the following functions:
lastColumn = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count
lastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
In the next step I want to select this area:
Formula should look like this:
Range(cells(1, 1), cells(lastRow, lastColumn).Select
However, this is not working. Maybe somebody has an idea what is wrong with it. Thanks a lot!
I recorded a macro with 'Relative References' and this is what I got :
Range("F10").Select
ActiveCell.Offset(0, 3).Range("A1:D11").Select
Heres what I thought : If the range selection is in quotes, VBA really wants a STRING and interprets the cells out of it so tried the following:
Dim MyRange as String
MyRange = "A1:D11"
Range(MyRange).Select
And it worked :) ie.. just create a string using your variables, make sure to dimension it as a STRING variables and Excel will read right off of it ;)
Following tested and found working :
Sub Macro04()
Dim Copyrange As String
Startrow = 1
Lastrow = 11
Copyrange = "A" & Startrow & ":D" & Lastrow
Range(Copyrange).Select
End Sub
I ran into something similar - I wanted to create a range based on some variables. Using the Worksheet.Cells did not work directly since I think the cell's values were passed to Range.
This did work though:
Range(Cells(1, 1).Address(), Cells(lastRow, lastColumn).Address()).Select
That took care of converting the cell's numerical location to what Range expects, which is the A1 format.
If you just want to select the used range, use
ActiveSheet.UsedRange.Select
If you want to select from A1 to the end of the used range, you can use the SpecialCells method like this
With ActiveSheet
.Range(.Cells(1, 1), .Cells.SpecialCells(xlCellTypeLastCell)).Select
End With
Sometimes Excel gets confused on what is the last cell. It's never a smaller range than the actual used range, but it can be bigger if some cells were deleted. To avoid that, you can use Find and the asterisk wildcard to find the real last cell.
Dim rLastCell As Range
With Sheet1
Set rLastCell = .Cells.Find("*", .Cells(1, 1), xlValues, xlPart, , xlPrevious)
.Range(.Cells(1, 1), rLastCell).Select
End With
Finally, make sure you're only selecting if you really need to. Most of what you need to do in Excel VBA you can do directly to the Range rather than selecting it first. Instead of
.Range(.Cells(1, 1), rLastCell).Select
Selection.Font.Bold = True
You can
.Range(.Cells(1,1), rLastCells).Font.Bold = True
You're missing a close parenthesis, I.E. you aren't closing Range().
Try this Range(cells(1, 1), cells(lastRow, lastColumn)).Select
But you should really look at the other answer from Dick Kusleika for possible alternatives that may serve you better. Specifically, ActiveSheet.UsedRange.Select which has the same end result as your code.
you are turning them into an address but Cells(#,#) uses integer inputs not address inputs so just use lastRow = ActiveSheet.UsedRange.Rows.count and lastColumn = ActiveSheet.UsedRange.Columns.Count
I tried using:
Range(cells(1, 1), cells(lastRow, lastColumn)).Select
where lastRow and lastColumn are integers, but received run-time error 1004. I'm using an older VB (6.5).
What did work was to use the following:
Range(Chr(64 + firstColumn) & firstRow & ":" & Chr(64 + lastColumn) & firstColumn).Select.

Consolitate data from multible sheets ,re-arrange the data as per the column name

i want a macro to consolidate the data form multiple sheets to one sheet.. here i given the example ..
Sheet 1
a1:Name b1:Age
a2:sathish b2:22
a3:sarathi b3:24
.
sheet 2
a1:Age b1:Name c1:Dept
a2:60 b2:saran c2:Comp sce
a3:31 b3:rajan c3:B.com
the result should be like this
consolidate sheet
a1:Name b1:Age c1:Dept
a2:sathish b2:22
a3:sarathi b3:24
a4:saran b4:60 c4:Comp sce
a5:rajan b5:31 c5:B.com
Here is the code which i used for consolidate data-
Sub consolidate()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
StartRow = 1
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
shLast = LastRow(sh)
If shLast > 0 And shLast >= StartRow Then
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
I can able consolidate the data but can't re-arrange as per the column title..
Please help me in this ..THanks in advance
First I identify some mistakes and bad practices in your code then I consider how to redesign your macro to achieve your objectives.
Issue 1
The primary purpose of On Error is to allow you to terminate tidily if an unexpected error occurs. You should not use it to avoid errors you expect and you should not ignore errors.
Consider the functions LastRow and LastCol. In both cases, if the Find fails, you ignore the error and carry on. But that means these functions return an incorrect value, so you get another error in the calling routine. If the Find fails you should investigate not ignore. This is true of any other error.
Issue 2
Find returns Nothing if the sheet is empty. You call functions LastRow and LastCol for worksheet "RDBMergeSheet" when it is empty. The code should be:
Set Rng = sh.Cells.Find( ...)
If Rng Is Nothing Then
' Sheet sh is empty
LastRow = 0
Else
LastRow = Rng.Row
End If
Here I have set LastRow to 0 if the worksheet is empty. This ceases to be a side effect of an error but a documented feature of the function: "Return value = 0 means the worksheet is empty." The calling routine must check for this value and skip any empty worksheets. There are other approaches but the key point is: provide code to handle expected or possible errors in a tidy manner. For function LastCol you need LastCol = Rng.Column.
Issue 3
The minimum syntax for a function statement is:
Function Name( ... parameters ...) As ReturnType
The two function statements should end: As Long.
Issue 4
Consider: "ActiveWorkbook.Worksheets("RDBMergeSheet")"
If you are working on multiple workbooks, ActiveWorkbook is not enough. If you are only working on one workbook, ActiveWorkbook is unnecessary. Please do not work with multiple workbooks until your understanding of Excel VBA is better.
Issue 5
You delete worksheet "RDBMergeSheet" and then recreate it which hurts my soul. More importantly, you have lost the column headings. I will discuss this matter further under Redesign.
Replace:
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
with:
Set DestSh = Worksheets("RDBMergeSheet")
With DestSh
.Range(.Cells(2, 1), .Cells(Rows.Count, Columns.Count)).EntireRow.Delete
End With
You use Rows.Count, With and Cells in your code so I will not explain them.
.Range(.Cells(RowTop, ColLeft), .Cells(RowBottom, ColRight)) is an easy method of specifying a range with the top left and bottom right cells.
I have used .EntireRow so I do not need the column numbers. The following gives the same effect:
.Rows("2:" & Rows.Count).EntireRow.Delete
As far as I know ClearContents (which some people favour) has the same effect as Delete. It certainly takes the same number of micro-seconds. For the usages above, both remove any values or formatting from the second row to the last row of the worksheet.
The above change means that row 1 is unchanged and the column widths are not lost. I do not need AutoFit which you have used.
Issue 6
Please be systematic in the naming of your variables. You use StartRow as the first row and shLast as the last row of the source worksheet and Last as the last row of the destination worksheet. Will a colleague who takes over maintenance of your macro find this easy to understand? Will you remember it in six months when this macro needs some maintenance?
Develop a naming system that works for you. Better still, get together with colleagues and agree a single system so all your employer's macros look the same. Document this system for the benefit of future staff. I would name these variables: RowNumDestLast, RowNumSrcStart and RowNumSrcLast. That is: <purpose of variable> <worksheet> <purpose within worksheet>. This system works for me but your system could be completely different. The key feature of a good system is that you can look at your code in a year and immediately know what each statement is doing.
Issue 7
If shLast > 0 And shLast >= StartRow Then
You set StartRow to 1 and never change it so if shLast >= StartRow then shLast > 0. The following is enough:
If shLast >= StartRow Then
Issue 8
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
It is good that you are checking for conditions that will result in fatal errors but is this the most likely error? Even if you are using Excel 2003, you have room for 65,535 people and a heading line. You will break the size limit on a workbook before you exceed the maximum number of rows.
Issue 9
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
This includes the heading row in the range to be copied. Since I will suggest a totally different method later, I will not suggest a correction.
Issue 10
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Why are you pasting the values and formats separately?
Redesign
With the corrections above, the code sort of works. With your source data, it sets the destination sheet to:
Age Name Dept
Name Age
Sathish 22
Sarathi 24
Age Name Dept
60 Saran Comp sce
31 Rajan B.com
This is not what you seek. So the rest of this answer is about design: how do you achieve the appearance you seek? There are many approaches but I offer one and explain why I have picked it without discussing alternatives.
Key issues:
How do you determine which columns to consolidate and in which sequence?
If there is a column in a source worksheet that you are not expecting, what do you do? Is someone collecting information for which there is no central interest or is the column name misspelt?
I have decided to use the existing column names within worksheet "RDBMergeSheet" to determine the sequence. To prepare the macro for a new column name, just add that name to "RDBMergeSheet". If I discover a column name in a source sheet that is not in "RDBMergeSheet", I add it on the right. This second decision will highlight the error if a column name is misspelt but will not be a benefit if someone is collecting extra information in a source worksheet.
I do not copy formats to worksheet "RDBMergeSheet" since, if the source worksheets are formatted differently, each part of worksheet "RDBMergeSheet" would be different.
New statements and explanations
Const RowFirstData As Long = 2
Const WShtDestName As String = "RDBMergeSheet"
A constant means I use the name in the code and can change the value by changing the Const statement.
I assume the first row of every worksheet contains column names and the first data row is 2. I use a constant to make this assumption clear. It would be possible to use this to write code that would handle a different number of heading rows but I have not done so because it would complicate the code for little advantage.
ColNumDestLast = .Cells(1, Columns.Count).End(xlToLeft).Column
.Cells(1, Columns.Count) identifies the last column of row 1 which I assume is blank. .End(xlToLeft) is the VBA equivalent of the keyboard Ctrl+Left. If .Cells(1, Columns.Count) is blank, .Cells(1, Columns.Count).End(xlToLeft) returns the first cell to the left which is not blank. .Column gives the column number of that cell. That is, this statement sets ColNumDestStart to the column number of the last cell in row 1 with a value.
ColHeadDest = .Range(.Cells(1, 1), .Cells(1, ColNumDestLast)).Value
This copies the values from row 1 to the variant array ColHeadDest. ColHeadDest will be redimensioned by this statement to (1 to 1, 1 to ColNumDestLast). The first dimension is for the rows, of which there is only one, and the second dimension is for the columns.
Replacement consolidate
I hope I have added enought comments for the code to make sense. You still need the corrected LastRow and LastCol. I could have replaced LastRow and LastCol but I think I have provided enough new code to be getting on with.
Option Explicit
Sub consolidate()
Dim ColHeadCrnt As String
Dim ColHeadDest() As Variant
Dim ColNumDestCrnt As Long
Dim ColNumDestLast As Long
Dim ColNumSrcCrnt As Long
Dim ColNumSrcLast As Long
Dim Found As Boolean
Dim RowNumDestCrnt As Long
Dim RowNumDestStart As Long
Dim RowNumSrcCrnt As Long
Dim RowNumSrcLast As Long
Dim WShtDest As Worksheet
Dim WShtSrc As Worksheet
Dim WShtSrcData() As Variant
Const RowNumFirstData As Long = 2
Const WShtDestName As String = "RDBMergeSheet"
'With Application
' .ScreenUpdating = False ' Don't use these
' .EnableEvents = False ' during development
'End With
Set WShtDest = Worksheets(WShtDestName)
With WShtDest
' Clear existing data and load column headings to ColHeadDest
.Rows("2:" & Rows.Count).EntireRow.Delete
ColNumDestLast = .Cells(1, Columns.Count).End(xlToLeft).Column
ColHeadDest = .Range(.Cells(1, 1), _
.Cells(1, ColNumDestLast)).Value
End With
' Used during development to check array loaded correctly
'For ColNumDestCrnt = 1 To ColNumDestLast
' Debug.Print ColHeadDest(1, ColNumDestCrnt)
'Next
RowNumDestStart = RowNumFirstData ' Start for first source worksheet
For Each WShtSrc In Worksheets
ColNumSrcLast = LastCol(WShtSrc)
RowNumSrcLast = LastRow(WShtSrc)
If WShtSrc.Name <> WShtDestName And _
RowNumSrcLast <> 0 Then
' Source sheet is not destination sheet and it is not empty.
With WShtSrc
' Load entire worksheet to array
WShtSrcData = .Range(.Cells(1, 1), _
.Cells(RowNumSrcLast, ColNumSrcLast)).Value
End With
With WShtDest
For ColNumSrcCrnt = 1 To ColNumSrcLast
' For each column in source worksheet
Found = False
ColHeadCrnt = WShtSrcData(1, ColNumSrcCrnt)
' Find matching column in destination worksheet
For ColNumDestCrnt = 1 To ColNumDestLast
If ColHeadCrnt = ColHeadDest(1, ColNumDestCrnt) Then
Found = True
Exit For
End If
Next ColNumDestCrnt
If Not Found Then
' Current source column's name is not present in the
' destination sheet Add new column name to array and
' destination worksheet
ColNumDestLast = ColNumDestLast + 1
ReDim Preserve ColHeadDest(1 To 1, 1 To ColNumDestLast)
ColNumDestCrnt = ColNumDestLast
With .Cells(1, ColNumDestCrnt)
.Value = ColHeadCrnt
.Font.Color = RGB(255, 0, 0)
End With
ColHeadDest(1, ColNumDestCrnt) = ColHeadCrnt
End If
' I could extract data from WShtSrcData to another array
' suitable for downloading to a column of a worksheet but
' it is easier to move the data directly to the worksheet.
' Also, athought downloading via an array is marginally
' faster than direct access, loading the array will reduce,
' and perhaps eliminate, the time benefit of using an array.
RowNumDestCrnt = RowNumDestStart
For RowNumSrcCrnt = RowNumFirstData To RowNumSrcLast
' Copy value from array of source data to destination sheet
.Cells(RowNumDestCrnt, ColNumDestCrnt) = _
WShtSrcData(RowNumSrcCrnt, ColNumSrcCrnt)
RowNumDestCrnt = RowNumDestCrnt + 1
Next
Next ColNumSrcCrnt
End With ' WShtDest
' Adjust RowNumDestStart ready for next source worksheet
RowNumDestStart = RowNumDestStart + RowNumSrcLast - RowNumFirstData + 1
End If ' Not destination sheet and not empty source sheet
Next WShtSrc
With WShtDest
' Leave workbook with destination worksheet visible
.Activate
End With
'With Application
' .ScreenUpdating = True
' .EnableEvents = True
'End With
End Sub