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
Related
Counter = Cells(Rows.Count, 4).End(xlUp).Row - 1
So I'm using this to look up occupied cells, but it's finding cells that have formulas that are IF's that end as "".
Can I convert this to look up visible text?
Thank you in advance
Last Row Excluding Cells Containing Formulas Evaluating to ""
Using the Find method
Here is a link to see what Microsoft states about the Find method.
Here is a link to Siddharth Rout's legendary post about using the Find method to find the last cell (row).
Note that Counter is 'pointing' one row above the Last Row.
The Code
Sub testGetLastRowInColumn()
Dim LastRow As Long
Dim Counter As Long
' Simple, for the ActiveSheet:
LastRow = getLastRowInColumn("A") ' 1 or "A", both are allowed.
Debug.Print LastRow
' Proper, for a certain sheet:
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet1")
LastRow = getLastRowInColumn("A", ws)
Debug.Print LastRow
' In your case
LastRow = getLastRowInColumn(4)
If LastRow > 0 Then
Counter = LastRow - 1
End If
Debug.Print LastRow, Counter
' In your case without the function:
LastRow = Columns(4).Find(What:="*", _
LookIn:=xlValues, _
SearchDirection:=xlPrevious).Row
If LastRow > 0 Then
Counter = LastRow - 1
End If
Debug.Print LastRow, Counter
' Or simplified:
LastRow = Columns(4).Find("*", , xlValues, , , xlPrevious).Row
If LastRow > 0 Then
Counter = LastRow - 1
End If
Debug.Print LastRow, Counter
' Or just (if you're sure that there is data in column 4):
Counter = Columns(4).Find("*", , xlValues, , , xlPrevious).Row - 1
Debug.Print LastRow, Counter
End Sub
Function getLastRowInColumn(ColumnIndex As Variant, _
Optional Sheet As Worksheet = Nothing, _
Optional includeEmpties As Boolean = False)
If Sheet Is Nothing Then
Set Sheet = ActiveSheet
End If
Dim FormVal As XlFindLookIn
If includeEmpties Then
FormVal = xlFormulas
Else
FormVal = xlValues
End If
Dim rng As Range
Set rng = Sheet.Columns(ColumnIndex).Find(What:="*", _
LookIn:=FormVal, _
SearchDirection:=xlPrevious)
If Not rng Is Nothing Then
getLastRowInColumn = rng.Row
Else
getLastRowInColumn = 0
End If
End Function
I have a range of data in excel which is uniform, Column A has a description, Column B has a unique ID and column C is blank. Then the next 3 columns have the same set of data. I am trying to get my vba loop to go down the two sets of data and compare the unique ID's, if there are differences it copies it to the range of data to a new sheet.
The issue is it is not just 6 columns of data its about a couple of hundred, so once the final row has been reached after checking the first range of data, the loop needs to move over 6 columns to begin the process again.
I am having some difficulty getting the loop to move across 6 columns once the finalrow has been reached
Sub finddata()
Dim s As Worksheet
Dim uniqueId As String
Dim finalrow As Long
Dim i As Long
Dim c As Long
Dim rngSearch As Range
Dim rngFound As Range
Dim finalcolumn As Long
Dim offset As Integer
Application.ScreenUpdating = True
uniqueId = Sheets("Data").Range("B2").Value
finalrow = Sheets("Data").Range("G100000").End(xlUp).Row
finalcolumn = Sheets("Data").Range("XFD1").End(xlToLeft).Column
offset = 3
Set s = Sheets("Data")
Set rngSearch = s.Range(s.Cells(2, 5), s.Cells(finalrow, 5))
Sheets("DataValidation").Range("A1:C100000").ClearContents
If i = finalrow GoTo 'guessing this is how to being to loop to move over columns
For i = 2 To finalrow
uniqueId = s.Cells(i, 2).Value
Set rngFound = rngSearch.Find(What:=uniqueId, LookIn:=xlValues, LookAt:=xlWhole)
If rngFound Is Nothing Then
s.Range(Cells(i, 1), Cells(i, 6)).Copy
Sheets("DataValidation").Range("A1048575").End(xlUp).offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
End If
Next i
MsgBox "Done"
End Sub
Try that one
For j = 1 to finalcolumn step 6
Set rngSearch = s.Range(s.Cells(2, j - 1 + 5), s.Cells(finalrow, j - 1 + 5))
For i = 2 To finalrow
uniqueId = s.Cells(i, 2 + j - 1).Value
Set rngFound = rngSearch.Find(What:=uniqueId, LookIn:=xlValues, LookAt:=xlWhole)
If rngFound Is Nothing Then
s.Range(Cells(i, 1 + j - 1), Cells(i, 6 + j - 1)).Copy
Sheets("DataValidation").Range("A1048575").End(xlUp). _
offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
End If
Next i
Next j
Hope it helps
Here is a short example of how you can iterate on uniform ranges of 3 columns, and moving right by offset of 6. You said your ranges are uniform so I hard-coded the initial value of rngSet.
In the For Each I'm printing the address of the cells but you can do your checks there. The While loop will end when it reaches an empty cell.
Dim rngSet As Range, rngRow As Range
Set rngSet = Range("A1:B6")
While Not IsEmpty(rngSet.Cells(1, 1).Value)
For Each rngRow In rngSet.Rows
Debug.Print rngRow.Cells(1, 1).Address
Next rngRow
Set rngSet = rngSet.Offset(0, 6)
Wend
**'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
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
I'm trying to get my code to insert four rows every time it finds a difference in the cell below. If A5-55 = 1, A56-80 = 2, A81 - 100 = 3 I want the code to see that 56 isn't equal to 55 and insert 4 rows, then continue down the A column until there are no more values.
I keep getting an error from Excel,
can not complete task. Resources error
And then a runtime 1004 insert method of range class failed, and the debugger highlights the code for inserting rows
This is what my data looks like:
Worksheets("HR-Calc").Activate
For lRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row To 6 Step -1
If Cells(lRow, "A") <> Cells(lRow - 1, "A") Then
Rows(lRow).EntireRow.Insert
Rows(lRow).EntireRow.Insert
Rows(lRow).EntireRow.Insert
Rows(lRow).EntireRow.Insert
End If
Next lRow
A neater way would be to use an autofilter on the table
(The code assumes that column A is a sorted integer ID - as seems to be the case from the image)
Sub InsertRowsBetweenIncrements()
Dim ws As Worksheet: Set ws = Worksheets("HR-Calc")
Dim HeaderRow As Long: HeaderRow = 4
Application.ScreenUpdating = False
Dim LastRow As Long: LastRow = ws.Columns(1).Find("*", _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim LastCol As Long: LastCol = ws.Cells.Find("*", _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Dim Tbl As Range: Set Tbl = ws.Range(Cells(HeaderRow, 1), Cells(LastRow, LastCol))
Dim i As Long, j As Long
For i = ws.Cells(LastRow, 1).Value To 1 Step -1
Tbl.AutoFilter Field:=1, Criteria1:=i
j = Tbl.SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeLastCell).Row
Tbl.AutoFilter
If j <> HeaderRow And j < LastRow Then _
ws.Rows(j + 1 & ":" & j + 4).Insert Shift:=xlDown
Next i
Application.ScreenUpdating = True
End Sub
If you want a less-clunky was (as you mentioned), I would default to using arrays to increase speed. Give the code below a try and see what you think. This assumes your data starts in row 6 (if not, change the value of "offset" to the final row before the data in question starts). If you want to change how many rows you insert in the future, just change the value of rows_to_insert to the desired number.
Sub insertrows()
Dim check_col() As Variant
Dim rng As Range
Dim lcell As Range
Dim i As Long
Dim rows_to_insert As Long
Dim rows_added As Long
Dim offset As Long
Dim insert_cell As Long
Worksheets("HR-Calc").Activate
lrow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set lcell = Cells(lrow, 1)
Set rng = Range("A6", lcell)
check_col = rng
rows_to_insert = 4
rows_added = 0
offset = 5
rows_added = 0
For i = 1 To (UBound(check_col, 1) - 1)
If check_col(i, 1) <> check_col(i + 1, 1) Then
check_col(i, 1) = i + rows_added + offset
rows_added = rows_added + rows_to_insert
Else: check_col(i, 1) = VBnllstring
End If
Next i
check_col(UBound(check_col, 1), 1) = vbNullString
rows_to_insert = rows_to_insert - 1
For i = 1 To UBound(check_col, 1)
If check_col(i, 1) <> vbNullString Then
insert_cell = check_col(i, 1) + 1
Range(Cells(insert_cell, 1), Cells(insert_cell + rows_to_insert, 1)).EntireRow.Select
Range(Cells(insert_cell, 1), Cells(insert_cell + rows_to_insert, 1)).EntireRow.Insert
End If
Next i
End Sub