I'm trying to set up a simple macro to add totals from column B based on the spread number of column A. Using VBA I have the following code:
Sub SpacingTotals()
Dim Rng As Range, Dn As Range, Temp As Range
Set Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
Set Temp = Rng(1)
For Each Dn In Rng
If Not Dn.Value = Temp Then
Set Temp = Dn
End If
Dn.Offset(, 0) = Dn.Value
Temp.Offset(, 2) = Temp.Offset(, 2) + Dn.Offset(, 1).Value
Next Dn
End Sub
The problem I'm having is more of a formatting issue. I want the totals on the last line of the spread criteria rather than the first line (See image).
Any push in the right direction would be appreciated.
Here's a version using the variable total to be the running total. When the spread in the next row doesn't match the current row, the total is written in the column to the right.
Sub SpacingTotals()
Dim total As Long
Dim spread As Range
For Each spread In Range("A2:A" & Range("A" & Rows.count).End(xlUp).Row)
total = total + spread.offset(0, 1).Value2
If spread.Value2 <> spread.offset(1, 0).Value2 Then
spread.offset(0, 2).Value2 = total
total = 0
End If
Next spread
End Sub
Related
I have the below code where in all other columns there is many populated rows, what I need this formula to do in column F is to find the first blank, then place the formula in it and fill it down to the last row.
What is currently happening is I have the range as F26 as this is usually first blank but this could change and I want the code to identify this and also have the formula dynamically know what row it is on, so for example if one month the first blank was in cell F30 the range would find it and the formula would start as E30*G30.
Any help would be greatly appreciated.
Private Sub calc()
Dim lastrow As Long
Dim rng As Range
lastrow = ThisWorkbook.Worksheets("Indiv").Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("F26:F" & lastrow)
rng.Formula = "=Round((E26*G26),2)"
End Sub
You need to find the first free row in column F and then bulid your formula with this row:
Option Explicit
Private Sub calc()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets("Indiv")
Dim LastRowA As Long ' find last used row in column A
LastRowA = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim FirstFreeRowF As Long ' find first free row in column F (if first 2 rows have data)
FirstFreeRowF = ws.Cells(1, "F").End(xlDown).Row + 1
' fix issue if first or second row is empty
If FirstFreeRowF = ws.Rows.Count + 1 Then
If ws.Cells(1, "F").Value = vbNullString Then
FirstFreeRowF = 1
ElseIf ws.Cells(2, "F").Value = vbNullString Then
FirstFreeRowF = 2
End If
End If
' define range to add formula
Dim Rng As Range
Set Rng = ws.Range("F" & FirstFreeRowF, "F" & LastRowA)
' add formula
Rng.Formula = "=Round((E" & FirstFreeRowF & "*G" & FirstFreeRowF & "),2)"
End Sub
So this will consider F5 the first free row and fill in the formula in the selected range as seen below:
I think you should find the last used row in column F, so that you could know the next row is blank
lastrowF=sheets(sheetname).range("F" & rows.count).end(xlup).row
So the next row would be like
range("F" & lastrowF+1).formula="Round((E" & lastrowF+1 & "*G" & lastrowF+1 & ",2)"
I cobbled together something that does work for me as is, but it runs very slowly and I'm sure the code can be simplified.
Sub CopyPasteValues()
Dim strSht1, strSht2 As String
Dim c, rng As Range
strSht1 = "Edit"
strSht2 = "LOB"
With ThisWorkbook.Sheets(strSht1)
Set rng = Range("J2:AJ37")
For Each c In rng
If Not c.Value = 0 Then
Cells(c.Row, 2).Copy
ThisWorkbook.Sheets(strSht2).Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Range(Cells(c.Row, 4), Cells(c.Row, 5)).Copy
ThisWorkbook.Sheets(strSht2).Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
c.Copy
ThisWorkbook.Sheets(strSht2).Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Cells(c.Column).Copy
ThisWorkbook.Sheets(strSht2).Range("G" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
Next c
End With
End Sub
I appreciate any assistance.
As BigBen Mentioned, array method.
Super Fast.
Sub Move_Values_Array_Method()
Dim SourceSheet As Worksheet 'Source Worksheet
Dim DestinationSheet As Worksheet 'Destination Worksheet
Dim RG As Range 'Source Range
Dim InArr() 'Data In Array
Dim OutArr() 'Data Out Array
Dim X As Long 'Array X Position for purposes of iterating through array.
Dim Y As Long 'Array Y Position for purposes of iterating through array.
Dim Cnt As Long 'Found Value Count
Set SourceSheet = ThisWorkbook.Worksheets("Edit") 'Set Source Worksheet
Set DestinationSheet = ThisWorkbook.Worksheets("LOB") 'Set Dest Worksheet
Set RG = SourceSheet.Range("J2:AJ37") 'Set Source Range
ReDim OutArr(1 To RG.Cells.Count) 'Count Cells in Range, resize output array to be at least that big.
InArr = RG 'Transfer Range Data to Array
Cnt = 0
Debug.Print LBound(InArr, 1) & " - " & UBound(InArr, 1) 'Rows
Debug.Print LBound(InArr, 2) & " - " & UBound(InArr, 2) 'Columns
For Y = 1 To UBound(InArr, 1) 'For Each Row in Array (or each Y position)
For X = 1 To UBound(InArr, 2) 'For Each Column in Array (or each X position)
If InArr(Y, X) <> "" Then 'If not blank Value (you can change this to "If InArr(Y, X) <> 0 Then" if that works best for you.
Cnt = Cnt + 1 'Increment "found value count" by 1
OutArr(Cnt) = InArr(Y, X) 'Add found value to output array
End If
Next X
Next Y
'Output to Dest Sheet
DestinationSheet.Range("F2").Resize(UBound(OutArr, 1), 1).Value = Application.Transpose(OutArr())
End Sub
Based on the information in your previous comments, try these alternative solution using formulas and filters...
1) Array Formulas
To note:
I have put everything on one sheet for clarity, but it works just as well over multiple sheets, or even workbooks.
If you want to filter the entire sheet, with same column order, you only need to enter formula once and expand "Array" criteria in formula to encapsulate entire data set.
Formula used in cell "J4" = "=FILTER($I$4:$I$30,$C$4:$C$30>0)"
(filter range I4 to I30 to show rows where value in range C4 to C30 is greater than 0)
2) Directly Filter
Alternatively, you could (either manually or programmatically) copy all data to LOB sheet, (or selectively copy), then filter for Qty>0.
I have excel with 5 different sheets.
sheet3 and sheet4 i want delete rows based on the single column cell value.
in sheet 3 i want to delete rows based on H column cell values if H2="#N/A" and H503="#N/A" then delete entire rows.
in sheet 4 i want to delete rows based on b column cell values if B2="320857876",B3="32085678",B4="12133435" the delete the entire rows where B column cell values starts with 302.
and i want to delete all Data from 'C' column
My excel sheet is like this
Using excel file
Sub Create()
Dim LastRow As Long
Dim i As Long
LastRow = Range("B10000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("B" & i) = "#N/A" Then
Range("B" & i).EntireRow.Delete
End If
Next
End Sub
You've got a few requirements there and your code is fairly light but regarding the #N/A part of it, you can't just test for that text using the value approach, which is the default property returned for a range object.
Sub Create()
Dim LastRow As Long, i As Long
LastRow = Range("B10000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("B" & i).Text = "#N/A" Then
Range("B" & i).EntireRow.Delete
End If
Next
End Sub
... you need to use .Text to get that to work, or, If IsError(Range("B" & i)) Then is another approach.
The rest of your requirements is just logic. The rest of your code is relatively sound so you just need to work through it.
I hope that helps.
Sub delete_rows()
Dim sheet As Worksheet, cell As Range
Count = 1
For Each sheet In ThisWorkbook.Worksheets
If Count = 3 Then
lastrow = sheet.Cells(sheet.Rows.Count, "H").End(xlUp).Row
Set Rng = sheet.Range("H1:H" & lastrow)
For i = Rng.Cells.Count To 1 Step -1
If Application.WorksheetFunction.IsNA(Rng(i).Value) Then
Rng(i).EntireRow.Delete
ElseIf Rng(i).Value = "#NA" Then
Rng(i).EntireRow.Delete
End If
Next
ElseIf Count = 4 Then
lastrow = sheet.Cells(sheet.Rows.Count, "B").End(xlUp).Row
Set Rng = sheet.Range("B1:B" & lastrow)
Debug.Print (Rng(4).Text)
If Rng(2).Value = "320857876" And Rng(3).Value = "32085678" And Rng(4).Value = "12133435" Then
For i = Rng.Cells.Count To 1 Step -1
If Left(Rng(i).Value, 3) = "302" Then
Rng(i).EntireRow.Delete
End If
Next
End If
lastrow = sheet.Cells(sheet.Rows.Count, "C").End(xlUp).Row
Set Rng = sheet.Range("C1:C" & lastrow)
For Each cell In Rng
cell.Value = ""
Next cell
End If
Count = Count + 1
Next
End Sub
I have a range of data, with CASE ID's in Column A, and Issues (1 through 10, or Columns B through K) in Columns B onwards.
Once certain issues are ruled out as 'normal', they would be removed from the Issues sheet based on their respective column. For ex: CASE ID #25, Issue 4 is ruled OK, then it would be deleted from Row 25, Column 5 (or Column E) but the CASE ID would remain.
The goal is that by doing this check after the fact, it may leave certain rows entirely blank, from Column B onwards (since the CASE ID would already be there.)
My code doesn't function successfully. Once run, it highlights several rows that are not entirely blank in the target range.
I'm trying to pinpoint rows in the range B2:P & lastrow where the entire row is blank, and then highlight these rows and subsequently delete them.
Code:
Public Sub EmptyRows()
lastrow = Sheets("Issues").Cells(Rows.Count, "A").End(xlUp).row
On Error Resume Next
Sheets("Issues").Activate
For Each rng In Range("B2:P" & lastrow).Columns
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Interior.ColorIndex = 11
'rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next rng
Application.ScreenUpdating = True
End Sub
The purpose of first highlighting is to test the code works. If successful, they would be deleted entirely.
Your description says Columns B through K, but your code has B through P...
You can do it like this (adjust resize for actual columns involved):
Public Sub EmptyRows()
Dim lastRow As Long, sht As Worksheet, c As Range, rngDel As Range
Set sht = Sheets("Issues")
For Each c In sht.Range(sht.Range("A2"), sht.Cells(Rows.Count, 1).End(xlUp)).Cells
If Application.CountA(c.Offset(0, 1).Resize(1, 10)) = 0 Then
'build range to delete
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(rngDel, c)
End If
End If
Next c
'anything to flag/delete ?
If Not rngDel Is Nothing Then
rngDel.EntireRow.Interior.ColorIndex = 11
'rngDel.EntireRow.Delete '<< uncomment after testing
End If
End Sub
Once run, it highlights several rows that are not entirely blank in the target range.
This is because you are selecting all blanks, instead of only rows where the entire row is blank.
See the code below
Public Sub EmptyRows()
With Sheets("Issues")
lastrow = .Cells(Rows.Count, "A").End(xlUp).row
Dim rng as Range
For Each rng In .Range("B2:B" & lastrow)
Dim blankCount as Integer
blankCount = Application.WorksheetFunction.CountA(rng.Resize(1,.Range("B:P").Columns.Count))
If blankCount = .Range("B" & lastRow & ":P" & lastRow).Columns.Count Then
Dim store as Range
If store Is Nothing Then Set store = rng Else: Set store = Union(rng, store)
End If
Next rng
End With
store.EntireRow.Interior.ColorIndex = 11
'store.EntireRow.Delete
End Sub
Gathering the ranges first and then modified them (changing color or deleting) will help to execute the code faster.
Here is another approach, using CountA
For Each cell In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Dim rng As Range
Set rng = Range("A" & cell.Row & ":" & "P" & cell.Row)
If Application.WorksheetFunction.CountA(rng) = 1 Then
rng.EntireRow.Interior.ColorIndex = 11
End If
Next cell
I am trying to develop a simple visualisation of a rack layout. I am able to get each item to appear in the rack at its lowest rack position (i.e. A 5 RU tall item that occupies slots 1-5 will appear in slot 1) (e.g. if my rack has 20 RUs, slot 1 (bottom of the rack) will be in row 20 and slot 20 (top of the rack) will be in row 1).
However i want to be able to merge the data in filled rows with the blank cells above.
So the item in slot 1 will have data in row 20, the next 4 rows will be blank until the next item appears in slot 6 (Row 15).
Each row has 4 cells on information to merge (i.e. range B:E or that row)
Item Name, RU height, ID1, ID2
I have realised I cannot use merge functions directly as it will overwrite the cells with the blanks in the top row. I believe i would need a function to copy the data row multiple times into the blank cells, based on the value in the RU height cell, before merging each column individually based on merging cells containing identical values.
I haven't been able to find any existing code that does something like this, I have however been able to adapt some code to handle the merge half of the problem, so if the data has been copied into the blank cells above it will merge successfully.
Sub MergeCells()
'set your data rows here
Dim Rows As Integer: Rows = 38
Dim First As Integer: First = 19
Dim Last As Integer: Last = 0
Dim Rng As Range
Application.DisplayAlerts = False
With ActiveSheet
For i = 1 To Rows + 1
If .Range("B" & i).Value <> .Range("B" & First).Value Then
If i - 1 > First Then
Last = i - 1
Set Rng = .Range("B" & First, "B" & Last)
Rng.MergeCells = True
Set Rng = .Range("C" & First, "C" & Last)
Rng.MergeCells = True
Set Rng = .Range("D" & First, "D" & Last)
Rng.MergeCells = True
Set Rng = .Range("E" & First, "E" & Last)
Rng.MergeCells = True
End If
First = i
Last = 0
End If
Next i
End With
Application.DisplayAlerts = True
End Sub
If someone can advise on how to get the data copied I should be able to cobble together a solution.
UPDATE..based on #TimWilliam answers i have put together the following code:
Sub MergeCellsX()
'set your data rows here
Dim Rows As Integer: Rows = 38
Dim col As Range
Dim First As Integer: First = 19
Dim Last As Integer: Last = 51
Dim rng As Range
With ActiveSheet
Set rng = .Range("B" & First, "B" & Last)
rng.Cells(1).Value = rng.Cells(rng.Cells.Count).Value 'copy last value to first cell
rng.MergeCells = True
Application.DisplayAlerts = False
For Each col In .Range("B" & First & ":E" & Last).Columns
MergeWithLastValue col
Next col
End With
Application.DisplayAlerts = True
End Sub
However it is putting the data in the very top on the range. It isnt taking into account the RU height value in column C.
I am not sure where the
Sub MergeWithLastValue(rng As Range)
With rng
.Cells(1).Value = .Cells(.Cells.Count).Value
.MergeCells = True
End With
End Sub
line of code should sit to reference this value?
Before and After:
EDIT - replaced everything with an approach based off the value in the "RU" cell
Sub MergeAreas()
Dim rw As Long, x As Long, rng As Range
Dim RU As Long, rngMerge As Range, col As Range
Dim rwEnd As Long
rw = 23
rwEnd = rw - 20
Do While rw >= rwEnd
' "Item#" column is 2/B
Set rng = ActiveSheet.Cells(rw, 3).Resize(1, 4)
If rng.Cells(1) <> "" Then
RU = rng.Cells(2).Value
'Here you need to check that the "RU space" doesn't extend
' past the top of the block
Set rngMerge = rng.Offset(-(RU - 1), 0).Resize(RU)
'here you should check for "collisions" between this
' item and anything above it in its RU space, otherwise
' the item above will get wiped out
For Each col In rngMerge.Columns
col.Cells(1).Value = col.Cells(col.Cells.Count).Value
Application.DisplayAlerts = False
col.MergeCells = True
Application.DisplayAlerts = True
Next col
rw = rw - RU
Else
rw = rw - 1
End If
Loop
End Sub