Can anyone help me adjust this code to fix my solution?
I have a button that adds x amount of new rows from A5 downwards. Columns A - Z.
I would like the new rows to be blank but still contain dropdowns and formula. New to VBA and struggling with this one.
I think I need to change the range and add xlPasteFormulas but unsure where and how for both. Any help hugely appreciated.
Option Explicit
Sub AddRows()
Dim x As Integer
x = InputBox("How many rows would you like to add?", "Insert Rows")
'Selecting range to insert new cells
Range(Cells(5, 1), Cells(x + 4, 1)).EntireRow.Insert
'Copys current cell A6 and past in the new cells
Cells(x + 5, 1).Copy Range(Cells(5, 1), Cells(x + 4, 1))
'if you want the cells to be blank but still have the drop down options
Range(Cells(5, 1), Cells(x + 4, 1)).ClearContents
End Sub
Please try the code below. It will copy everything from the BaseRow and then delete constant values in that range, leaving formats, including data validations, and formulas.
Sub AddRows()
Const BaseRow As Long = 11 ' modify to suit
Dim x As String ' InputBox returns text if 'Type' isn't specified
Dim Rng As Range
Dim R As Long
x = InputBox("How many rows would you like to add?", "Insert Rows")
If x = "" Then Exit Sub
R = BaseRow + CInt(x) - 1
Rows(BaseRow).Copy 'Copy BaseRow
'specify range to insert new cells
Set Rng = Range(Cells(BaseRow, 1), Cells(R, 1))
Rng.Insert Shift:=xlDown
' insert the new rows BEFORE BaseRow
' to insert below BaseRow use Rng.Offset(BaseRow - R)
Set Rng = Rng.Offset(BaseRow - R - 1).Resize(Rng.Rows.Count, ActiveSheet.UsedRange.Columns.Count)
Rng.Select
On Error Resume Next
Rng.SpecialCells(xlCellTypeConstants).ClearContents
Application.CutCopyMode = False '
End Sub
The code now has an emergency exit: If you don't enter anything in the InputBox the procedure terminates. Note that new rows are inserted above the BaseRow. After the insertion all new rows and the old row are identical. You can then choose to retain the constants in either the first or the last of these rows, effectively meaning, insert new, blank rows either above or below the BaseRow.
Related
My 2010 macro updates on opening a sheet. Does 2016 work the same when when they have the target sheet opened in a new 'instance'? It has to be idiot proof (I don't know why they asked me to do it :P). So the macro has to run once when opening the sheet; if the sheet is opened on the second monitor run every time a value is inserted over 119 in the source sheet; Don't run unnecessary because of the potentially very large sheets and meh laptops.
I've made this macro so the sheets my colleges are using don't need 'complex' formulas or macros to clear blank rows before it's exported to Word. I've made it in 2010, but I can't test it on 2016 til next week.
The macro that on the target sheet (J03);
Private Sub worksheet_activate()
And on the source sheet (WTB);
Private Sub Run_When_Value_Greather_Than_119_Is_Entered_In_Column_G()
Google is clogged with answers and results about blank rows, copying, blank rows, running on other activation ways and non blank rows. I probably don't know what to look for either.
The full code;
Private Sub worksheet_activate()
Dim Max As Long, MaxD As Long 'Determine the amount of filled rows
Dim wsWtB As Worksheet, wsJ03 As Worksheet
Dim wb As Workbook
Dim i As Integer, j As Integer 'i and j for the row numbers
Application.ScreenUpdating = False 'screenupdating of for max speeds
Set wb = ThisWorkbook
Set wsJ03 = Sheets("J_03")
Set wsWtB = Sheets("WTB")
Max = WorksheetFunction.Max(wsWtB.Range("A3:A1600")) 'Amount of rows with data
Max = Max + 3 'Ignore the headers
MaxD = WorksheetFunction.Max(wsJ03.Range("A3:A1600"))
MaxD = MaxD + 2
j = 9 'The rownumber where the copying needs to start
wsJ03.Range("B9", Cells(MaxD, 5)).ClearContents 'Clear the old values
For i = 3 To Max 'The copying loop has to start after the headers at row 3
If wsWtB.Cells(i, 7).Value > 119 Then 'Do stuff if...
wsJ03.Cells(j, "B").Value = Chr(39) & wsWtB.Cells(i, "B").Value 'At a '
wsJ03.Cells(j, "C").Value = Chr(39) & wsWtB.Cells(i, "C").Value 'at the start
wsJ03.Cells(j, "D").Value = Chr(39) & wsWtB.Cells(i, "D").Value 'so a zero is
wsJ03.Cells(j, "E").Value = Chr(39) & wsWtB.Cells(i, "E").Value 'displayed
j = j + 1 'Set the next row for the target sheet
Else
End If
Next i
Application.ScreenUpdating = True
End Sub
It's the first piece of code that I got working without hiccups :-) Feel free to comment and ad the propper tags.
Koen.
Edit; (Alternative ways to look for the last cell)
?thisworkbook.sheets("WTB").cells(rows.Count,"A").end(xlup).row
1047 '<- Rownumber of the last cell with a Formula to create/force
successive
numbers
?thisworkbook.sheets("WTB").columns("A").Find(What:="*", LookIn:=xlValues,
SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
5 '<- Rownumber of the last cell with a value. Includes the header
rows
?WorksheetFunction.Max(thisworkbook.sheets("WTB").Range("A3:A1600"))
3 '<- Highest number in A3:A1600 and also the amount units/rows that
need to be copied to "J_03"
I needed a function that gave me the amount of 'things' on the sheet. In this case it's 3, but it could go up to 1600.
Edit 2; (google sheet so you can see what i'm working on)
https://docs.google.com/spreadsheets/d/1I5qLeOS0DWcwncs_ium_J0Vp6b4nzTsiE0ndbKtpsC0/edit?usp=sharing
Edit 3; there was an error in the clear range part.
wsJ03.Range("B9", Cells(MaxD, 5)).ClearContents 'Clear the old values
You could use something like the following, but make sure you place the code in the Sheet where the values might be changing (Sheets("WTB")):
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 7 Then 'If something changed in column G
If Target.Value > 119 Then 'and if the value is higher than 119
NextFreeRow = Sheets("J_03").Cells(.Rows.Count, "B").End(xlUp).Row + 1
'Or Do your copying stuff, you can use Target.column or Target.row to find the address of the cell that got a value higher than 119
Sheets("J_03").Cells(NextFreeRow, "B").Value = Chr(39) & Sheets("WTB").Cells(Target.Row, "B").Value 'At a '
Sheets("J_03").Cells(NextFreeRow, "C").Value = Chr(39) & Sheets("WTB").Cells(Target.Row, "C").Value 'at the start
Sheets("J_03").Cells(NextFreeRow, "D").Value = Chr(39) & Sheets("WTB").Cells(Target.Row, "D").Value 'so a zero is
Sheets("J_03").Cells(NextFreeRow, "E").Value = Chr(39) & Sheets("WTB").Cells(Target.Row, "E").Value 'displayed
End If
End If
End Sub
2 months later, thought i'd show my final work;
The Union() functions lets you (or me in this case), improve the speed of the sheets:
For i = 1 to LastRow
If Ws1.Cells(i, 1).Value > 119 Then
Union(Ws2.Cells(i, 4), Ws2.Cells(i, 5), Ws2.Cells(i, 6)).Value =
Union(Ws1.Cells(y, 1), Ws1.Cells(y, 2), Ws1.Cells(y, 3)).Value: y = y + 1
end if
Next
It's about 30% faster then using cel1, 2, 3.value = cel5, 6, 7.value when it's simply copying all rows without the If.
When my workbook needs to fill 50 sheets like this and has 25 rows of data it took 4,5 seconds on average, with the Union() it's 1,6. When there are 1000 rows its goes from ~23 to 9 seconds but the variations is very high. Depending on the If's;
For some sheets it's not "If > 119 then";
If cellAL.Value = "x" Then 'if the cell exactly "x" Then do stuf
If Not cellAL.Value <> vbNullString Then 'if the cell = NotEmpty
vbNullString
is faster then "" because it's actually less ones and zeros
If InStr(cellAll, "x") Then 'looks for all x's in the cell.
To find the last row without beein affected by format, formulas and other stuff;
myLastRow = .Columns("A").Find(What:="*", LookIn:=xlValues, _
SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
"*" 'is something like "any/all characters". A Space or Alt + Enter can make
a big mess
try the direct window to see what it does:
?activesheet.Columns("A").Find(What:="*", LookIn:=xlValues, _
SearchDirection:=xlPrevious).Row
Ps for my CanaDerp buddy; Hope you can get it working with this!
I have a rather large sheet (approx 60K rows by 50 cols). I'm trying to copy several (2 to 8) rows into clipboard and then insert copied cells. This operation takes more than a minute to complete!
I've tried disabling automatic calculations, initiating this operation from VBA, like this:
Range("A1").Insert xlShiftDown
to no available. If I paste (Ctrl-V) rather than insert it works like a snap.
Any ideas how to work around this issue?
Since you can paste the data quickly enough use that instead of inserting, then sort the rows:
In an empty column on the first row of data type the number of rows you want to insert plus 1 (e.g. to insert 3 rows type 4)
Add the next number in the next row, then select both cells and autocomplete the column so that each row has an increasing number
Paste the new data at the end of the old data, immediately after the last row
Number the first row pasted as 1, the 2nd as 2 etc
Sort the sheet ascending on the number column then delete the column
I implemented Absinthe's algorithm, here's the code:
Sub InsertRows()
Dim SourceRange, FillRange As Range
Dim LastCol, LastRow, ActRow, CpdRows As Long
Dim i As Integer
If Application.CutCopyMode <> xlCopy Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
With ActiveSheet
LastCol = .UsedRange.Columns.Count
LastRow = .UsedRange.Rows.Count
ActRow = ActiveCell.Row
.Paste Destination:=.Cells(LastRow + 1, 1)
CpdRows = .UsedRange.Rows.Count - LastRow
Application.Calculation = xlCalculationManual
Set SourceRange = .Range(.Cells(ActRow, LastCol + 1), .Cells(ActRow + 1, LastCol + 1))
SourceRange.Cells(1).Value = CpdRows + 1
SourceRange.Cells(2).Value = CpdRows + 2
Set FillRange = .Range(.Cells(ActRow, LastCol + 1), .Cells(LastRow, LastCol + 1))
SourceRange.AutoFill Destination:=FillRange
For i = 1 To CpdRows
.Cells(LastRow + i, LastCol + 1).Value = i
Next i
.Range(.Cells(ActRow, 1), .Cells(LastRow + CpdRows, LastCol + 1)).Sort Key1:=.Cells(ActRow, LastCol + 1), _
Order1:=xlAscending, Header:=xlNo, MatchCase:=False, Orientation:=xlTopToBottom
.Columns(LastCol + 1).Delete
End With
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
It's works definitely faster than "insert copied cells" and it seems it's accelerating after the 1st use (I mean, when I run the macro for the 2nd, 3rd etc time it works even faster than on the 1st run). There are the cons, too. For example, named ranges do not automatically expand when you insert the lines in this manner.
And the most significant problem of this method: Excel does not move the borders with the cells when sorting. Therefore, the border structure will be ruined. The only workaround I know of is to use conditional formatting for the borders.
This all being said, it's a good workaround
Bellow is part of my codes and my coding is almost done, but now I found a big problem that it's necessary to be corrected.
I use this code on a sheet with over 10000 rows and my purpose is to update a column using Index & Match functions. What it's doing is that it replaces all cells of range in column J with corresponding values from another sheet. The big problem is that I don't want cells that have no matching item be replaced with #N/A and they keep their old values.
What should I do?
Dim SourceRange As Range
Dim fillRange As Range
'bellow formula in A1 notation:
'=INDEX('[myWB.xls]Sheet1'!$A:$B;
'IF(INDEX('[myWB.xls]Sheet1'!$A:$A;MATCH(C4;'[myWB.xls]Sheet1'!$A:$A))=C4;
' MATCH(C4;'[myWB.xls]Sheet1'!$A:$A);
' NA());
' 2)
ActiveCell.FormulaR1C1 = _
"=INDEX([myWB.xls]Sheet1!C1:C2,IF(INDEX([myWB.xls]Sheet1!C1,MATCH(R[-11]C[-12],[myWB.xls]Sheet1!C1))=R[-11]C[-12],MATCH(R[-11]C[-12],[myWB.xls]Sheet1!C1),NA()),2)"
' autofill formula in column
Set SourceRange = Cells(2, 10)
Set fillRange = Range(Cells(2, 10), Cells(10000, 10))
With SourceRange
.AutoFill Destination:=fillRange, Type:=xlCopy
End With
'replace formula with its value
With Range(Cells(2, 10), Cells(10000, 10))
.Value = .Value
End With
Update
This is my current code with some improvements. Thanks to Rob Anthony for his help.
Dim calc As XlCalculation
Dim f as String
With Workbooks(FinalWB.xls).Worksheets(1) 'Worksheet to be updated
calc = Application.Calculation
Application.Calculation = xlCalculationAutomatic 'Ensure automatic calculation is ON
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Column J to Column Z
Range(.Cells(2, 26), .Cells(10000, 26)).Value = _ ' Col Z =
Range(.Cells(2, 10), .Cells(10000, 10)).Value ' Col J
f = "=if(ISERROR(INDEX([myWB.xls]Sheet1!C1:C2,IF(INDEX([myWB.xls]Sheet1!C1,MATCH(R[-11]C[-12],[myWB.xls]Sheet1!C1))=R[-11]C[-12],MATCH(R[-11]C[-12],[myWB.xls]Sheet1!C1),NA()),2)),RC[16],INDEX([myWB.xls]Sheet1!C1:C2,IF(INDEX([myWB.xls]Sheet1!C1,MATCH(R[-11]C[-12],[myWB.xls]Sheet1!C1))=R[-11]C[-12],MATCH(R[-11]C[-12],[myWB.xls]Sheet1!C1),NA()),2))"
With Range(.Cells(2, 10), .Cells(10000, 10))
.FormulaR1C1 = f 'fill formula without Autofill
.Value = .Value 'replace formula with its value
End With
'Delete Column Z
.Columns(26).EntireColumn.Delete
End With
Application.Calculation = calc
Application.ScreenUpdating = True
Application.EnableEvents = True
'This is above formula. now seems so easy to understand :)
' f =
' "=IF( 'if calculations result an error...
' ISERROR(
' INDEX([myWB.xls]Sheet1!C1:C2,
' IF(
' INDEX([myWB.xls]Sheet1!C1,
' MATCH(R[-11]C[-12],
' [myWB.xls]Sheet1!C1)
' )=R[-11]C[-12],
' MATCH(R[-11]C[-12],
' [myWB.xls]Sheet1!C1),
' NA()
' ),
' 2
' )
' ),
' RC[16], 'use previousely copied value of the cell...
' INDEX([myWB.xls]Sheet1!C1:C2, 'else use that calculations
' IF(
' INDEX([myWB.xls]Sheet1!C1,
' MATCH(R[-11]C[-12],
' [myWB.xls]Sheet1!C1)
' )=R[-11]C[-12],
' MATCH(R[-11]C[-12],
' [myWB.xls]Sheet1!C1),
' NA()
' ),
' 2
' )
' )
' "
The easiest way to solve this is to copy and paste Column J into a new column (say Z). Then, put this formula into Column J
=if(ISERROR(INDEX([myWB.xls]Sheet1!C1:C2,IF(INDEX([myWB.xls]Sheet1!C1,MATCH(R[-11]C[-12],[myWB.xls]Sheet1!C1))=R[-11]C[-12],MATCH(R[-11]C[-12],[myWB.xls]Sheet1!C1),NA()),2)),RC[16],INDEX([myWB.xls]Sheet1!C1:C2,IF(INDEX([myWB.xls]Sheet1!C1,MATCH(R[-11]C[-12],[myWB.xls]Sheet1!C1))=R[-11]C[-12],MATCH(R[-11]C[-12],[myWB.xls]Sheet1!C1),NA()),2))
I check to see whether the formula returns a valid value, if it does not, then I put in the value from Column Z (I have assumed that RC[16] is a valid reference for this, from your earlier comment), otherwise I put in the value as calculated.
Without seeing your spreadsheet, it is difficult to see exactly what you are trying to do. It might be possible to shorten this function.
Hello and first let me say thank you!
I use Excel to capture user requirements and descriptions. I then take that information and clean it up and paste into presentation docs, apply formatting, paste into Powerpoint, etc. It can be 100s of lines in total that this is done for. What I'm looking for is a macro that I can apply to data once it is pasted into Excel. The data will be text, non-numeric
I have a macro that I use to insert a blank row as every other row. I then do everything else manually (macro shown below).
What I'm looking for is a macro that inserts a blank row, then offsets Column 2 by 1 row down. then pastes column 1 into column 2(without copying the blank cells over my already existing data in column 2).
I've pasted a link to an image of what I'm looking for. I've also tried to show below (numbers are column 1, letters are column 2).
2 columns to 1 column - desired result
1 A 2 B3 C
Result I want:
1
A
2
B
3
C
My current "Blank Row" Macro:
Sub insertrow()
' insertrow Macro
Application.ScreenUpdating = True
Dim count As Integer
Dim X As Integer
For count = 1 To 300
If ActiveCell.Value <> "" Then
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.Offset(0, 0)).EntireRow.Insert
ActiveCell.Offset(1, 0).Select
For X = 1 To 1
Next X
Else
ActiveCell.Offset(1, 0).Range("a1").Select
End If
Next count
End Sub
This should work, but you'll have to adjust a little for your exact layout and needs.
Sub mergeColumns()
Dim mergedData As Variant
ReDim mergedData(1 To 600)
dataToProcess = Range("A2:B301")
For i = 1 To 300
mergedData(i * 2 - 1) = dataToProcess(i, 1)
mergedData(i * 2) = dataToProcess(i, 2)
Next i
Range("B2:B601") = WorksheetFunction.Transpose(mergedData)
End Sub
The following does what you need without inserting blank rows. It also calculates what the last row is on the sheet that has 2 columns so that you don't need to hard-code when the loop will end.
The comments should help you understand what is happening each step of the way. You can then modify this to work with your particular workbook. There are a lot of ways you could go about this. I chose to put the pivoted result on a second sheet.
Sub PivotTwoColumnsIntoOne()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim rng As Range
Dim cell As Range
Dim lastRow As Long
Dim targetRow As Long
Set wb = ThisWorkbook
' set our source worksheet
Set src = wb.Sheets("Sheet1")
' set our target sheet (where the single column will be)
Set tgt = wb.Sheets("Sheet2")
' get the last row on our target sheet
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
' set the starting point for our target sheet
targetRow = 1
Set rng = src.Range("A1:A" & lastRow)
For Each cell In rng
With tgt.Range("A" & targetRow)
' get the value from the first column
.Value = cell.Value
' get the value from the second column
.Offset(1).Value = cell.Offset(, 1).Value
.HorizontalAlignment = xlLeft
End With
targetRow = targetRow + 2
Next cell
End Sub
I'm looking for a way to copy a range of cells, but to only copy the cells that contain a value.
In my excel sheet I have data running from A1-A18, B is empty and C1-C2. Now I would like to copy all the cells that contain a value.
With Range("A1")
Range(.Cells(1, 1), .End(xlDown).Cells(50, 3)).Copy
End With
This will copy everything from A1-C50, but I only want A1-A18 and C1-C2 to be copied seen as though these contain data. But it needs to be formed in a way that once I have data in B or my range extends, that these get copied too.
'So the range could be 5000 and it only selects the data with a value.
With Range("A1")
Range(.Cells(1, 1), .End(xlDown).Cells(5000, 3)).Copy
End With
Thanks!
Thanks to Jean, Current code:
Sub test()
Dim i As Integer
Sheets("Sheet1").Select
i = 1
With Range("A1")
If .Cells(1, 1).Value = "" Then
Else
Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Sheet2").Range("A" & i)
x = x + 1
End If
End With
Sheets("Sheet1").Select
x = 1
With Range("B1")
' Column B may be empty. If so, xlDown will return cell C65536
' and whole empty column will be copied... prevent this.
If .Cells(1, 1).Value = "" Then
'Nothing in this column.
'Do nothing.
Else
Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Sheet2").Range("B" & i)
x = x + 1
End If
End With
Sheets("Sheet1").Select
x = 1
With Range("C1")
If .Cells(1, 1).Value = "" Then
Else
Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Sheet2").Range("C" & i)
x = x + 1
End If
End With
End Sub
A1 - A5 contains data, A6 is blanc, A7 contains data. It stops at A6 and heads over to column B, and continues in the same way.
Since your three columns have different sizes, the safest thing to do is to copy them one by one. Any shortcuts à la PasteSpecial will probably end up causing you headaches.
With Range("A1")
Range(.Cells(1, 1), .End(xlDown)).Copy myDestinationRangeA
End With
With Range("B1")
' Column B may be empty. If so, xlDown will return cell C65536
' and whole empty column will be copied... prevent this.
If .Cells(1, 1).Value = "" Then
'Nothing in this column.
'Do nothing.
Else
Range(.Cells(1, 1), .End(xlDown)).Copy myDestinationRangeB
EndIf
End With
With Range("C1")
Range(.Cells(1, 1), .End(xlDown)).Copy myDestinationRangeC
End With
Now this is ugly, and a cleaner option would be to loop through the columns, especially if you have many columns and you're pasting them to adjacent columns in the same order.
Sub CopyStuff()
Dim iCol As Long
' Loop through columns
For iCol = 1 To 3 ' or however many columns you have
With Worksheets("Sheet1").Columns(iCol)
' Check that column is not empty.
If .Cells(1, 1).Value = "" Then
'Nothing in this column.
'Do nothing.
Else
' Copy the column to the destination
Range(.Cells(1, 1), .End(xlDown)).Copy _
Destination:=Worksheets("Sheet2").Columns(iCol).Cells(1, 1)
End If
End With
Next iCol
End Sub
EDIT
So you've changed your question... Try looping through the individual cells, checking if the current cell is empty, and if not copy it. Haven't tested this, but you get the idea:
iMaxRow = 5000 ' or whatever the max is.
'Don't make too large because this will slow down your code.
' Loop through columns and rows
For iCol = 1 To 3 ' or however many columns you have
For iRow = 1 To iMaxRow
With Worksheets("Sheet1").Cells(iRow,iCol)
' Check that cell is not empty.
If .Value = "" Then
'Nothing in this cell.
'Do nothing.
Else
' Copy the cell to the destination
.Copy Destination:=Worksheets("Sheet2").cells(iRow,iCol)
End If
End With
Next iRow
Next iCol
This code will be really slow if iMaxRow is large. My hunch is that you're trying to solve a problem in a sort of inefficient way... It's a bit hard to settle on an optimal strategy when the question keeps changing.
Take a look at the paste Special function. There's a 'skip blank' property that may help you.
To improve upon Jean-Francois Corbett's answer, use .UsedRange.Rows.Count to get the last used row. This will give you a fairly accurate range and it will not stop at the first blank cell.
Here is a link to an excellent example with commented notes for beginners...
Excel macro - paste only non empty cells from one sheet to another - Stack Overflow