I am trying to do the following in Excel:
The easiest way is of course to just drag and drop, but as I have many rows and columns, this is not feasible.
I was thus thinking that the following should work:
=IF(B6="Food", "Food", "insert two blank cells")
However, to my surprise, I was unable to find seomthing which would allow me to actually use "insert shift cells down" in a formula. What do I overlook, do I need to get started with VBA here?
Thanks!
I believe the following code would do what you expect:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your Sheet above
lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'find the last row with data on Column A
For i = 6 To lastrow 'loop from row 6 to last
If ws.Cells(i, 1).Value = "Food" Then 'if Food is found
ws.Cells(i, 2).Insert Shift:=xlDown 'insert a blank cell on Column B
ws.Cells(i, 2).Insert Shift:=xlDown 'again insert a second blank cell on Column B
End If
Next i
End Sub
Related
I am trying to extend a sum formula to a dynamic range. The sum includes all values from row 5 till the second last used row in the column, the sum is then in the last used row. However, the number of rows and columns vary, the only thing that stays the same is that the sum should always start in row 5. The sum starts also always in column C. I already managed to write a macro that puts the sum in the last row of column C. I am now working on a macro that extends this sum to all other used columns in the sheet, except for the last column (that contains another value and not a sum).
I am working with selection.autofill. However, I am having issues with declaring the range that i want to fill. VBA gives me an "expected: end of statement" error and I can't figure out why. Can somebody explain to me what I am doing wrong? Is there a better method than selection.autofill - i fear that it might not take over the columns, e.g. actually summing up column D when extended to the cell in column D ?
Here is what i already have:
'
' sumtest Macro
'
'
Dim Cell As Range, sRange As Range
Dim wsDestination As Worksheet
With ThisWorkbook
Set wsDestination = .Worksheets("Overview")
End With
FirstRow = Rows(5).EntireRow
lastRow = wsDestination.Cells(Rows.Count, "A").End(xlUp).Row
LastRow1 = wsDestination.Cells(Rows.Count, "A").End(xlUp).Row
LastColumn1 = wsDestination.Cells(4, wsDestination.Columns.Count).End(xlToLeft).Column
Worksheets("Overview").Select
wsDestination.Cells(lastRow, "C").Select
ActiveCell.Formula = "=SUM(C5:C" & lastRow - 1 & ")"
Range(wsDestination.Cells(LastRow1, 3)).Select
Selection.AutoFill Destination:=Range(wsDestination.Cells(LastRow1,3),wsDestination.Cells(LastRow1,LastColumn -1)) Type:=xlFillDefault
End Sub
This code would write the value of the sum in each column for the last row:
Option Explicit
Sub Sumtest()
With ThisWorkbook.Sheets("Overview")
Dim LastCol As Long: LastCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
Dim Cell As Range
Dim LastRow As Long
For Each Cell In .Range("C4", .Cells(4, LastCol))
LastRow = .Cells(.Rows.Count, Cell.Column).End(xlUp).Row
.Cells(LastRow, Cell.Column) = Application.Sum(.Range(Cell.Offset(1), .Cells(LastRow - 1, Cell.Column)))
Next Cell
End With
End Sub
Note that the code will check the LastRow for every column, so if the columns have different amount of rows the total will be on the first row without data for each column.
My Dataset is as such: Column A = ID numbers, Column B = Test Type, Column C = Results.
Each ID in Column A appears more than once. For each occurrence, there is a test with the result being either "Yes" or "No".
If one test result for a given ID comes back "Yes", I want to copy all rows for that ID to a new sheet in the same workbook.
So in the photo I've attached: ID 1234, test type Blue came back with "Yes", while test type Pink was "No". I want to copy both rows of ID 1234 to a new sheet because one or more of the tests (Blue or Pink) came back "Yes". ID 4321 should be left untouched because both tests were "No".
I've no idea on how to start this, I'm sure 'If, Then' statements may be involved.
Any suggestions how to tackle this in VBA?
Sheet with ID, Test Type and Results: an example but there would be about 1000+ rows of data.
Is this ok ?
Sub filter_and_copy()
' Variables
Dim oWsFrom As Worksheet
Dim oWsTo As Worksheet
Dim oRangeData As Range
Dim nbRow As Long
' Settings
Set oWsFrom = ThisWorkbook.Worksheets("sheet1")
Set oWsTo = ThisWorkbook.Worksheets("sheet2")
oWsTo.Cells.ClearContents
Set oRangeData = oWsFrom.Cells(1, 1).CurrentRegion
nbRow = oRangeData.Rows.Count
' Formula and filter
With oWsFrom
.Cells(1, 4).Value = "Formula"
.Cells(2, 4).Formula = "=COUNTIFS(A:A,A2,C:C,""yes"")"
.Cells(2, 4).AutoFill Destination:=.Range(.Cells(2, 4), .Cells(nbRow, 4))
.AutoFilterMode = False
.Rows(1).AutoFilter Field:=4, Criteria1:="1"
End With
' Copy
oWsFrom.Range(Columns(1), Columns(3)).SpecialCells(xlCellTypeVisible).Copy oWsTo.Cells(1, 1)
End Sub
This is the final code, which uses .Calculate to force the formula to work automatically every time I run the macro. Thanks again for the help
Worksheets("Total").Activate
'add column to put formula in
Range("B1").EntireColumn.Insert
Dim LstRwCD As Long
With ActiveSheet
LstRwCD = .Range("A" & Rows.Count).End(xlUp).Row
End With
Range("B2:B" & LstRwCD) = "=COUNTIFS(A:A,A2,N:N,""Yes"")"
Range(Range("B2"), Range("B" & LstRwCD)).FillDown
'This forces the formula to calculate
Worksheets("Total").Columns(2).Calculate
'filter if 1 or 2, all with at least one Yes in a pair.
Selection.AutoFilter
ActiveSheet.Range("A:T").AutoFilter Field:=2, Criteria1:="1", Operator:=xlOr, Criteria2:="2"
Worksheets("Total").Range("A1:T" & LstRwCD).Copy Worksheets("Total Yes").Range("A1")
'delete the columns with the formula
Sheets("Total Yes").Range("B:B").EntireColumn.Delete
Sheets("Total").Range("B:B").EntireColumn.Delete
I have a sheet where the cells in Column A auto-populate based on user input. Row 1 is the Headers. Row 2 is fully setup from B:JG with formulas as an example. I would like to have a button that runs a script to check Column A of each row, starting with 3, to see if its empty. If Column A is not empty, it should copy the FORMULAS from B2:JG2 and paste them into Columns B:JG on each row. If Column A is empty, I want it to leave the other columns blank.
I'm just diving into VBA, so any help with a script to accomplish is appreciated.
Example: Rows 3-110 have data in Column A, so B2:JG2 FORMULAS get copied into their B:JG columns. All rows after 110 get nothing because Column A is empty.
The button is on a sheet called "HexBox" and the sheet I need to update is "HexClean".
The user enters some info on the "HexBox" sheet and A:A is auto-populated based on their answers. So there could be 10 or 1000 rows in A:A with values and the rest up to 5000 will be "" if not applicable.
This approach simply
Copies the formulas from 2nd row down to the last used row as determined by Column A (one operation). Note that this step is indifferent of blanks in your column. That is handled in the following 2 steps
Loops through Column A and gather up instances of blank rows by adding them to a Union (collection of cells) (0 operations)
Clears the contents of the Union that is built in step 2 (one operation)
This is a more effecient way to go. Copying & pasting the formulas inside your loop one row at a time will lead to a lot of spread sheet operations. This method has a max of 2 operations
Sub HexSub()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("HexClean")
Dim LR As Long, i As Long, ClearMe As Range
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("B2:JG2").Copy
ws.Range(ws.Cells(3, "B"), ws.Cells(LR, "JG")).PasteSpecial xlPasteFormulas
For i = 3 To LR
If ws.Range("A" & i) = "" Then
If Not ClearMe Is Nothing Then
Set ClearMe = Union(ClearMe, ws.Range("A" & i))
Else
Set ClearMe = ws.Range("A" & i)
End If
End If
Next i
If Not ClearMe Is Nothing Then ClearMe.EntireRow.ClearContents
End Sub
If your range will never have blanks followed by more values, then you can just get rid of the loop and everything below it
If the non-blank cells in column A are typed values then SpecialCells should be able to find them quickly.
Sub populateBelow()
Dim frng As Range
With Worksheets("sheet3")
Set frng = .Range(.Cells(2, "B"), .Cells(2, "JG"))
With .Range(.Cells(3, "A"), .Cells(.Rows.Count, "A").End(xlUp))
With .SpecialCells(xlCellTypeConstants, xlTextValues + xlNumbers)
frng.Copy Destination:=.Offset(0, 1)
End With
End With
End With
End Sub
Sub CopyToMany()
Dim xRow As Range, aCel As Range
For Each xRow In ActiveSheet.UsedRange.Rows
If xRow.Row > 2 Then
Set aCel = xRow.Cells(1, 1)
If aCel.Value <> "" Then
ActiveSheet.Range("B2:JG2").Copy Destination:=ActiveSheet.Range("B" & xRow.Row & ":JG" & xRow.Row)
End If
End If
Next xRow
End Sub
I have an excel spread sheet set up for my partner's home business where she can input data relating to people joining the business. I am looking to have the data from that row cut and paste to a separate sheet depending on the criteria in one of the cells. The main sheet is called "Workspace".
If the person on row 6 has agreed to join the business then a "Yes" would be placed in cell V6. Once the Yes has been input I am aiming for the columns A:G to be cut and paste onto the sheet "Joined" as well as the rest of that row being deleted and preferably the rows underneath moving up one (if that is possible). The data would be pasted onto the next blank row on the "Joined" sheet.
On the flip side, if the person on row 6 states they are uninterested then a "Not Interested" would be placed in cell H6. Once the not interested has been input I am aiming for the columns A:G to be cut and paste onto the sheet "Not Interested" as well as the rest of that row being deleted, like above.
Is it also possible to have the spread sheet sort names alphabetically each time a new name is added? The starting row for data is 6.
I hope this all makes sense and really hope someone is able to assist. I am quite good when it comes to formulas but not got a clue where to start with regards to macros.
This is my code so far:
Sub Test()
For Each Cell In Sheets("Workspace").Range("V:V")
If Cell.Value = "Yes" Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Joined").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Workspace").Select
End If
Next
End Sub
Here is a good starting point for you. I added comments to the code so you can see what every line does.
This sub searches for "yes" in column V and copies Range A:G of the columns with "yes" into sheet Joined. Then it deletes the entire row where the "yes" was found.
I think from here you can do the second part for "Not Accepted" on your own.
Sub Test()
Dim MatchRow As Long, FirstRow As Long, LastRow As Long
Dim Destination As Range
Dim ws As Worksheet
Set ws = Sheets("Workspace") 'define ws as sheet workspace (shortcut)
FirstRow = 6 'First row with data below headline
LastRow = ws.Cells(ws.Rows.Count, "V").End(xlUp).Row 'Get last used row in column V (so we don't need to go through the full column)
Dim i As Long
i = FirstRow
Do While i <= LastRow 'start searching for "Yes" in FirstRow and end in LastRow
If ws.Range("V" & i).Value = "Yes" Then
MatchRow = ws.Range("V" & i).Row 'remember matched row number
'find last free row in column A of sheet Joined and remember in Destination
With Sheets("Joined")
Set Destination = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
'Copy range A:G from matched row to destination found above
ws.Range("A" & MatchRow & ":G" & MatchRow).Copy Destination
'Delete copied entire row
ws.Rows(MatchRow).EntireRow.Delete
'reduce LastRow by one (because we deleted one row)
LastRow = LastRow - 1
Else
'go to next row
i = i + 1
End If
Loop
End Sub
Was wondering if someone could help me problem solve something with the attached example dataset. I have many more so trying to work out an efficient way to do this:
https://www.dropbox.com/s/fa32ddeh4lbz8lo/Problem%20removing%20blanks%20cells%20and%20corresponding%20left%20cell.xlsx?dl=0
In the attached excel data sheet are sets of 2 columns side-by-side marked by lines (TIME and GLU). I have used conditional formatting to highlight (in red) the blank cells in each GLU columns. What I want to do (without having to go through by hand...) is remove these blank cells (i.e. delete and move that whole column upwards) AND also delete and move upwards the single 'TIME' cell immediately to the left of each of these blank cells (as illustrated for example by the green highlighted TIME cells in column A alongside column B).
Does anyone out there know how this might be achieve via code?? Would be extremely helpful!!
Thanks in advance!
Patrick
Sub RemoveBlank()
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim Column As Long
Application.ScreenUpdating = False
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastColumn = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
Column = 2
Do While Column <= LastColumn
LastRow = sht.Range(Cells("1", Column - 1), Cells("1", Column - 1)).CurrentRegion.Rows.Count
Row = LastRow
Do While Row > 1
If sht.Range(Cells(Row, Column), Cells(Row, Column)).Value = "" Then
'Delets the two column row with a blank GLU and moves the rest of the data up.
sht.Range(Cells(Row, Column - 1), Cells(Row, Column)).Select
Selection.delete Shift:=xlUp
Else
'Do nothing
End If
Row = Row - 1
Loop
Column = Column + 2
Loop
Application.ScreenUpdating = True
End Sub