I have 100K Excel file that has many employee info, I want to shift all existence data to the first row for this employee, the picture below will be louder than my words, can a VBA code do this? or there is a trick in excel that I am not aware of
Try following code.
Sub Demo()
Dim ws As Worksheet
Dim cel As Range, rng As Range
Dim lastRow As Long, lastCol As Long, i As Long
Dim fOccur As Long, lOccur As Long, colIndex As Long
Dim dict As Object, c1
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Sheet1") 'change Sheet1 to your data range
Set dict = CreateObject("Scripting.Dictionary")
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row with data in Column A
lastCol = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column 'last column with data in Sheet1
Set rng = .Range("A1:A" & lastRow) 'set range in Column A
c1 = .Range("A2:A" & lastRow)
For i = 1 To UBound(c1, 1) 'using dictionary to get uniques values from Column A
dict(c1(i, 1)) = 1
Next i
colIndex = 16 'colIndex+1 is column number where data will be displayed from
For Each k In dict.keys 'loopthrough all unique values in Column A
fOccur = Application.WorksheetFunction.Match(k, rng, 0) 'get row no. of first occurrence
lOccur = Application.WorksheetFunction.CountIf(rng, k) 'get row no. of last occurrence
lOccur = lOccur + fOccur - 1
'copy range from left to right
.Range(.Cells(fOccur, 1 + colIndex), .Cells(lOccur, lastCol + colIndex)).Value = .Range(.Cells(fOccur, 1), .Cells(lOccur, lastCol)).Value
'delete blanks in range at right
.Range(.Cells(fOccur, 1 + colIndex), .Cells(lOccur, lastCol + colIndex)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp 'delte blank rows
Next k
End With
Application.ScreenUpdating = True
End Sub
Try the below. You can amend the below code to match where you want to move the range:
Dim oW As Worksheet: Set oW = ThisWorkbook.Worksheets("Sheet8")
With oW.UsedRange
.Cut .Offset(0, .Columns.Count + 2)
End With
Related
I have a data set as shown below
The goal is to take the column totals manually (below the row "Total") and take the variance with the system extracted values to validate the accurcy.
I have used the below code to choose the column dynamically and take the totals to automate the process.
Sub ColTotals()
'1. Identifying the relevant column, in this case Beg bal
ThisWorkbook.Worksheets("Output").Cells.Find(What:="Beg bal", After:=Range("A1"), LookIn:=xlValues _
, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False).Activate
'2.Assignment of column values
C_OI = ActiveCell.Column
'Find the last non-blank cell in column B
lRow = ThisWorkbook.Worksheets("Output").Cells(Rows.Count, 2).End(xlUp).Row
Debug.Print (lRow) '
'3. loop to calculate sum from the last row until first row excluding header
Sum_OI = 0
For i = lRow To C_OI
Sum_OI = Sum_OI + Worksheets("Output").Cells(i, C_OI).Value
Next
Worksheets("Output").Cells(lRow + 2, C_OI).Value = Sum_OI.Value 'At the end of loop, assigns the column total to the required field,
'Take variance to identify for any difference
Worksheets("Output").Cells(lRow + 2, C_OI).Value = Cells(lRow + 1, C_OI).Value - Cells(lRow, C_OI).Value 'Calculating the difference between Report sum and calculated sum
End Sub
However, I'm unable to achieve with the above code, as no output is thrown and also no error message to debug or identify the issue.
Alternative way/correction to the above code would be much appreciated.
Checking Totals
Option Explicit
Sub ColTotals()
Const wsName As String = "OutPut"
Const hTitle As String = "Beg bal"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim hCell As Range
Set hCell = ws.Cells.Find(hTitle, , xlFormulas, xlWhole, xlByRows)
If hCell Is Nothing Then Exit Sub ' header not found
Dim Col As Long: Col = hCell.Column
Dim fRow As Long: fRow = hCell.Row + 1
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
Dim Total As Double
Dim r As Long
For r = fRow To lRow - 1
Total = Total + ws.Cells(r, Col).Value
Next
ws.Cells(lRow + 1, Col).Value = Total
ws.Cells(lRow + 2, Col).Value = Total - ws.Cells(lRow, Col).Value
End Sub
Goal: Add the string "Z" to a select few columns for all rows except the header. Concatenate only on select headers i.e. headers defined in the array.
Dim header As Range
ArrayCheck = Array("CarTime", "BusTime", "PlaneTime")
LastRow = desWS1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lcol = desWS1.Cells(1, Columns.Count).End(xlToLeft).Column
For Each header In desWS1.Range(desWS1.Cells(1, 1), desWS1.Cells(1, lcol))
For i = LBound(ArrayCheck) To UBound(ArrayCheck)
If header = ArrayCheck(i) Then
desWS1.Range(desWS1.Cells(2, header.Column), desWS1.Cells(LastRow, header.Column)) & "Z"
End If
Next i
Next
all entries in these columns are of the form: yyyy-mm-ddThh:mm:ss
#SiddharthRout the current cell is: 2020-09-07T13:08:46, and the output i want is: 2020-09-07T13:08:46Z. So yep, you're right, it's a string. – Jak Carty 2 mins ago
In my below code, I will take a sample of both date and date stored as text. I have commented the code so you should not have a problem understanding it. But if you do then simply post back.
Is this what you are trying?
Code:
WAY 1
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, lCol As Long
Dim ArrayCheck As Variant
Dim i As Long, j As Long
Dim rng As Range
ArrayCheck = Array("CarTime", "BusTime", "PlaneTime")
'~~> Set this to the relevant worksheet
Set ws = Sheet1
With ws
'~~> Find last row
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Find last col
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'~~> Loop though the cell in 1st row
For i = 1 To lCol
'~~> Loop through the array
For j = LBound(ArrayCheck) To UBound(ArrayCheck)
'~~> Check if they match
If .Cells(1, i).Value2 = ArrayCheck(j) Then
'~~> Set your range from cell 2 onwards
Set rng = .Range(.Cells(2, i), .Cells(lRow, i))
'~~> Add "Z" to the entire range in ONE GO i.e without looping
'~~> To understand this visit the url below
'https://stackoverflow.com/questions/19985895/convert-an-entire-range-to-uppercase-without-looping-through-all-the-cells
rng.Value = Evaluate("index(Concatenate(" & rng.Address & ",""Z""" & "),)")
End If
Next j
Next i
End With
End Sub
Note: For the sake of clarity, I am not joining the string ",""Z""" & "),)")
In Action
WAY 2
Introducing a 2nd way
This code writes to array and then works with it.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, lCol As Long
Dim ArrayCheck As Variant
Dim i As Long, j As Long, k As Long
Dim rng As Range
Dim tmpAr As Variant
ArrayCheck = Array("CarTime", "BusTime", "PlaneTime")
'~~> Set this to the relevant worksheet
Set ws = Sheet1
With ws
'~~> Find last row
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Find last col
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'~~> Loop though the cell in 1st row
For i = 1 To lCol
'~~> Loop through the array
For j = LBound(ArrayCheck) To UBound(ArrayCheck)
'~~> Check if they match
If .Cells(1, i).Value2 = ArrayCheck(j) Then
'~> Set your range
Set rng = .Range(.Cells(2, i), .Cells(lRow, i))
'~~> Store the value in array
tmpAr = rng.Value2
'~~> Work with array
For k = 1 To UBound(tmpAr)
tmpAr(k, 1) = tmpAr(k, 1) & "Z"
Next k
'~~> write the array back to worksheet
rng.Resize(UBound(tmpAr), 1).Value = tmpAr
End If
Next j
Next i
End With
End Sub
In Action
I am trying to make something that would look like this:
In the table on the right there will be all the unique records which will be stored in a certain area. However some record may be existing in more areas, and this information can be taken from the list in column A and B. The macro should take each unique record in column D and search for it in Column A, every time it finds it, should copy the location/area in column B and pasted next to the unique record in the table. I think I could do this with a loop, but what I created in the code below does not really works.
The second challenge is to make it understand that in a location has been copy into the table, the new found location needs to be pasted in the next free cell of that same unique record.
I am aware my code is a little scare but I would appreciate even just advice on which direction I should be looking... Thanks in advance!
Sub searcharea()
Dim UC As Variant, UCrng As Range, ra As Range
Set UCrng = Range("F2:F6")
For Each UC In UCrng
Set ra = Cells.Find(What:=UC, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ra.Offset(0, 1).Copy Destination:=Range("E2")
Next
End Sub
I would suggest looping through all Rows (Columns A + B), e.g.:
For i = 1 to Rows.Count
'DoStuff
Next i
For each row, you copy the value of A into D, if it is not there already.
You can access the values like this:
Cells(i, "A").Value
Cells(i, "B").Value
For finding values in a column, see here. If you found a duplicate, use another loop to check which column (E, F, G,..) in your specific row is the first empty one, and past the value of column B there.
Take a try:
Option Explicit
Sub test()
Dim LastRowA As Long, LastRowD As Long, i As Long, rngColumn As Long
Dim rng As Range
With ThisWorkbook.Worksheets("Sheet1")
LastRowD = .Cells(.Rows.Count, "D").End(xlUp).Row
.Range("D2:J" & LastRowD).ClearContents
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRowA
LastRowD = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rng = .Range("D1:D" & LastRowD).Find(.Range("A" & i).Value, LookIn:=xlValues, lookat:=xlWhole)
If Not rng Is Nothing Then
rngColumn = .Cells(rng.Row, .Columns.Count).End(xlToLeft).Column
Cells(rng.Row, rngColumn + 1).Value = .Range("B" & i).Value
Else
.Range("D" & LastRowD + 1).Value = .Range("A" & i).Value
.Range("E" & LastRowD + 1).Value = .Range("B" & i).Value
End If
Next i
End With
End Sub
I think this code will do what you want. Please try it.
Option Explicit
Sub SortToColumns()
' Variatus #STO 30 Jan 2020
Dim WsS As Worksheet ' Source
Dim WsT As Worksheet ' Target
Dim Rng As Range
Dim Fn As String, An As String ' File name, Area name
Dim Rls As Long
Dim Rs As Long
Dim Rt As Long, Ct As Long
With ThisWorkbook ' change as required
Set WsS = .Worksheets("Sheet1") ' change as required
Set WsT = .Worksheets("Sheet2") ' change as required
End With
With WsT
' delete all but the caption row
.Range(.Cells(2, 1), .Cells(.Rows.Count, "A").End(xlUp)).EntireRow.ClearContents
End With
Application.ScreenUpdating = False
With WsS
' find last row of source data
Rls = .Cells(.Rows.Count, "A").End(xlUp).Row
For Rs = 2 To Rls ' start from row 2 (row 1 is caption)
Fn = .Cells(Rs, "A").Value
An = .Cells(Rs, "B").Value
If FileNameRow(Fn, WsT, Rt) Then
' add to existing item
With WsT
Ct = .Cells(Rt, .Columns.Count).End(xlToLeft).Column
Set Rng = .Range(.Cells(Rt, "B"), .Cells(Rt, Ct))
End With
With Rng
Set Rng = .Find(An, .Cells(.Cells.Count), xlValues, xlWhole, xlByRows, xlNext)
End With
' skip if Area exists
If Rng Is Nothing Then WsT.Cells(Rt, Ct + 1).Value = An
Else
' is new item
WsT.Cells(Rt, "A").Value = Fn
WsT.Cells(Rt, "B").Value = An
End If
Next Rs
End With
Application.ScreenUpdating = True
End Sub
Private Function FileNameRow(Fn As String, _
WsT As Worksheet, _
Rt As Long) As Boolean
' Rt is a return Long
' return True if item exists (found)
Dim Fnd As Range
Dim Rng As Range
Dim R As Long
With WsT
R = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range(.Cells(2, "A"), .Cells(R, "A"))
Set Fnd = Rng.Find(Fn, Rng.Cells(Rng.Cells.Count), xlValues, xlWhole, xlByRows, xlNext)
If Fnd Is Nothing Then
Rt = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 2)
Else
Rt = Fnd.Row
FileNameRow = True
End If
End With
End Function
I need to do a Vlookup of an ID on the source sheet to a table in the data sheet. When the Vlookup is done, it needs to return the cell values from 6 different columns.
Here I have a function to get the range:
Function find_Col(header As String) As Range
Dim aCell As Range, rng As Range, def_Header As Range
Dim col As Long, lRow As Long, defCol As Long
Dim colName As String, defColName As String
Dim y As Workbook
Dim ws1 As Worksheet
Set y = Workbooks("Template.xlsm")
Set ws1 = y.Sheets("Results")
With ws1
Set def_Header = Cells.Find(what:="ID", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
Set aCell = .Range("B2:Z2").Find(what:=header, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
defCol = def_Header.Column
defColName = Split(.Cells(, defCol).Address, "$")(1)
col = aCell.Column
colName = Split(.Cells(, col).Address, "$")(1)
lRow = Range(defColName & .Rows.count).End(xlUp).Row - 1
Set myCol = Range(colName & "2")
'This is your range
Set find_Col = Range(myCol.Address & ":" & colName & lRow).Offset(1, 0)
'If not found
Else
MsgBox "Column Not Found"
End If
End With
End Function
Then in my sub, I select the range and do a Vlookup which fills this range:
Selection.FormulaR1C1 = "=VLOOKUP(RC[-4],myTable,2,FALSE)"
And this works great.
Then I needed to return more than just one column, so I ended up with the formula:
Selection.FormulaArray = "=VLOOKUP($C3,myTable,{2,3,4,5,6},FALSE)"
Source Sheet:
Data Sheet:
So, my function returns only the range for one column, which I think I can use in terms of getting a row count then using something like this:
Set myRng = find_Col("Product")
For currentRow = myRng.Rows.count To 1 Step -1
Selection.FormulaArray = "=VLOOKUP($C3,myTable,{2,3,4,5,6},FALSE)"
Next currentRow
Then perhaps instead of C3 it could look something like this:
C & currentRow --> Selection.FormulaArray = "=VLOOKUP($C & currentRow,myTable,{2,3,4,5,6},FALSE)"
But then I have the issue that only one cell is selected (G3) and from H-L is not. And I have no idea whether this is even a plausible effort.
Ideally of course, I would have cells G3:L3 selected and fill the formula down to the last row.
My brain is just fried from all the thinking and attempts.
So this should do the trick... I've explained every instance but if you need help understanding just ask:
Option Explicit
Sub FillData1()
Dim ws As Worksheet, wsData As Worksheet, arr As Variant, arrData As Variant
Dim DictHeaders As Scripting.Dictionary, DictIds As Scripting.Dictionary, DictDataHeaders As Scripting.Dictionary, _
DictDataIds As Scripting.Dictionary
Dim LastRow As Long, LastCol As Integer, i As Long, j As Integer
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With ThisWorkbook
Set ws = .Sheets("Results")
Set wsData = .Sheets("List")
End With
'Lets suppose your data always starts on row 2 in both sheets and column B will always have the max amount of rows filled
With ws 'filling the first array
LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
arr = .Range("B2", .Cells(LastRow, LastCol)).Value
End With
With wsData 'filling the data array
LastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
arrData = .Range("A2", .Cells(LastRow, LastCol)).Value
End With
'Now lets put everything into Dictionaries so if the data moves columns or rows won't matter
Set DictHeaders = New Scripting.Dictionary
Set DictIds = New Scripting.Dictionary
For i = 1 To UBound(arr, 2) 'this will fill the headers positions on the main sheet
If Not DictHeaders.Exists(arr(1, i)) Then DictHeaders.Add arr(1, i), i
Next i
For i = 2 To UBound(arr, 1) 'this will fill the IDs positions on the main sheet
If Not DictIds.Exists(arr(i, DictHeaders("KW ID"))) Then DictIds.Add arr(i, 1), i
Next i
Set DictDataHeaders = New Scripting.Dictionary
Set DictDataIds = New Scripting.Dictionary
For i = 1 To UBound(arrData, 2) 'this will fill the headers positions on the data sheet
If Not DictDataHeaders.Exists(arrData(1, i)) Then DictDataHeaders.Add arrData(1, i), i
Next i
For i = 2 To UBound(arrData, 1) 'this will fill the IDs positions on the data sheet
If Not DictDataIds.Exists(arrData(i, DictDataHeaders("KW ID"))) Then DictDataIds.Add arrData(i, DictDataHeaders("KW ID")), i
Next i
'Finally will loop through the main array to fill it with the data from the data array
On Error Resume Next
For i = 2 To UBound(arr)
For j = 6 To UBound(arr, 2) 'I'm assuming you want to avoid the first columns which are hidden
arr(i, j) = arrData(DictDataIds(arr(i, 1)), DictDataHeaders(arr(1, j)))
Next j
Next i
On Error GoTo 0
With ws 'filling the first array
LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
.Range("B2", .Cells(LastRow, LastCol)).Value = arr
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I don't know if I got the true issue of your goal. However, since your Selection parts in your code should be avoid, why don't make something like the following?
Set myRng = find_Col("Product")
For currentRow = myRng.Rows.count To 1 Step -1
Range(Cells(currentRow, 5), Cells(currentRow, 9)).FormulaArray = "=VLOOKUP(RC3,myTable,{2,3,4,5,6},FALSE)"
Next currentRow
**'Dim raport As Worksheet
'Dim daty As String
'Dim lcolumn As Long
'Dim mycolaaa As String
'Dim dataT As Variant
'Set raport = ActiveWorkbook.Sheets("sheet1")
'raport.Activate
'lcolumn = raport.Cells(1, Columns.Count).End(xlToLeft).Column
'daty = ("A1:xy1")
'With raport
'raport.Range(daty).Select
'End With
'Selection.Copy
'dataT = Application.Transpose(Data)
'With tarws
'CopyRangeAddress = .Range("A2:A100").Address
' .Range(CopyRangeAddress).PasteSpecial xlPasteValues
'.Range(CopyRangeAddress).PasteSpecial xlPasteFormats
'.Range(CopyRangeAddress).PasteSpecial xlPasteColumnWidths
'End With
srcws.Activate
'With srcws
'.Range(sortrangeaddress).Select
'End With
'Selection.Copy
'Paste the Sort Range on to the target worksheet
'The CopyRangeAddress will be A1 through the last Row
'and column 2 -- so something like A1:B2
'With tarws
'CopyRangeAddress = .Range(.Cells(pasteRow, pasteCol), _
'.Cells(pasteRow + lrow - 2, 2)).Address
'.Range(CopyRangeAddress).PasteSpecial xlPasteValues
'.Range(CopyRangeAddress).PasteSpecial xlPasteFormats
'.Range(CopyRangeAddress).PasteSpecial xlPasteColumnWidths
'End With**
How to add "daty" cells instead of sortrangeadress? It is data from source worksheet in one row as header of below cells that you helped me with transposing. Thank you a lot for previous answers!
From your pictures it looks like you are attempting to un-pivot a pivot table. Your best bet to tackle this is to create smaller ranges for each "date" groupings. The code below provides an example of how to move through the groupings.
Option Explicit
Public Sub Example()
Const firstDataCell As Long = 3 'Column C
Const columnsInDataGroup As Long = 10
Const DataRowStart As Long = 2 'Row 2
'Worksheet with the source data
Dim srcWs As Worksheet
Set srcWs = ActiveWorkbook.Sheets("Sheet1")
'Worksheet to write data to
Dim tarWs As Worksheet
Set tarWs = ActiveWorkbook.Sheets("Sheet2")
'Get the last row of data
Dim lRow As Long
lRow = LastRow(srcWs)
'Get the last column containing data
Dim lCol As Long
lCol = LastColumn(srcWs)
'This are the first columns you seem to
'want to sort the data on
Dim SortRangeAddress As String
SortRangeAddress = "A2:B" & Trim(CStr(lRow))
'This variable will contain the address of
'each Date Data Group as your macro
'loops across the columns
Dim dateDataGroupRangeAddress As String
Dim row As Long
Dim col As Long
Dim pasteRow As Long: pasteRow = 1
Dim pasteCol As Long: pasteCol = 1
Dim CopyRangeAddress As String
For col = firstDataCell To lCol Step columnsInDataGroup
'Copy the Sort Range from the source worksheet to
'the target worksheet.
With srcWs
.Range(SortRangeAddress).Select
End With
Selection.Copy
'Paste the Sort Range on to the target worksheet
'The CopyRangeAddress will be A1 through the last Row
'and column 2 -- so something like A1:B2
With tarWs
CopyRangeAddress = .Range(.Cells(pasteRow, pasteCol), _
.Cells(pasteRow + lRow - 2, 2)).Address
.Range(CopyRangeAddress).PasteSpecial xlPasteValues
End With
'Copy the next source date data group. The width of the selection
'is determine by columnsInDataGroup constant set above less 1
'Think of the first .Cells as 1 and the second .Cells as
'columnsInDataGroup - 1.
With srcWs
dateDataGroupRangeAddress = .Range(.Cells(DataRowStart, col), _
.Cells(lRow, col + columnsInDataGroup - 1)).Address
.Range(dateDataGroupRangeAddress).Select
End With
Selection.Copy
'Paste the next source date date group to the target worksheet
'CopyRangeAddress here will move 2 columns over from the
'Start of the sort data range (Columns A & B) to start the
'paste in column C
With tarWs
CopyRangeAddress = .Range(.Cells(pasteRow, pasteCol + 2), _
.Cells(pasteRow + lRow - 2, columnsInDataGroup + 2)).Address
.Range(CopyRangeAddress).PasteSpecial xlPasteValues
End With
pasteRow = pasteRow + lRow - 1
Next col
End Sub
Function LastRow(ByRef sh As Worksheet)
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
End Function
Function LastColumn(ByRef sh As Worksheet)
LastColumn = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End Function