I want to copy some data from 2 columns ("Nastavit D" sheet, column Q2 to R1000) to the end of the columns with similar data on another sheet ("Chain" sheet, column A1 to B1000). I have a code for this, but I need improvement so that it copies the border formats too. Also, If cell C3 in sheet called "Nedotykat sa!!!" is TRUE, then I want it to copy the data to Sheet called "Chain" BEFORE any other data (basically putting in it A1, "pushing" the existing data there down below the new copied data), instead of putting it to the end. I have a code for copying and putting the data into the end of "Chain" sheet.
Sub CopyRange()
Dim x, y(), I As Long, ii As Long
If Sheets("Nastavit D").[Q2] = "" Then Exit Sub
x = Sheets("Nastavit D").[Q2:R1000]
For I = 1 To UBound(x, 1)
If x(I, 1) <> "" Then
ReDim Preserve y(1 To 2, 1 To I)
For ii = 1 To 2
y(ii, I) = x(I, ii)
Next
Else: Exit For
End If
Next
With Sheets("Chain")
.Cells(.rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(y, 2), 2) = Application.Transpose(y)
End With
End Sub
EDIT:
I started to rewrite the whole VBA code based on suggestions by #BigBen and #Jeff. However, for now, it copies the whole range of Q2:R1000, even blank cells, because they contain formulas I think. How can I copy only cells with actual values, even if it contains formulas?
Sub CopyRangeUpdated()
Dim lastRow As Long
lastRow = Sheets("Chain").Range("A65536").End(xlUp).Row + 1
If Sheets("Nastavit D").[Q2] = "" Then Exit Sub
Sheets("Nastavit D").Range("Q2:R1000").Copy
Sheets("Chain").Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues, SkipBlanks:=True
'clear clipboard
Application.CutCopyMode = False
End Sub
Here is a sample code for #BigBen's suggestion
Edited in response to question edit
The skip blanks not compress what is copied to remove blanks, it will just "skip over" them. for example:
1 A
_ B
3 C
pasting col1 onto col2 will result in:
1
B
3
'copy range
Sheets("Nastavit D").Range("Q2:R1000").Copy
'paste values
Sheets("Chain").Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
'clear clipboard
Application.CutCopyMode = False
'copy formatting
Sheets("Nastavit D").Range("Q2:R1000").Copy
'paste formatting
Sheets("Chain").Range("A1").PasteSpecial xlPasteFormats
To "push data down", I would insert cells beforehand:
Sheets("Chain").Rows("2:1001").insert Shift:=xlDown
Then delete blank rows with something like this (the i is there to prevent an infinite loop if the last row is blank)
i=2
for x = 2 to 1001
if i<10001 then
if sheet("Chain").Range("A"&x).text = "" then
Sheet("Chain").Range("A"&x).entirerow.delete xlshiftup
'if say row2 is deleted, need to re-check row2 new value
x = x-1
end if
else
exit for
end if
i=i+1
next x
Related
I am trying to write some VBA that does two things:
When a value J column = "XY" duplicate the row by inserting the same data into a row below
In the newly inserted row, change values in G, H & L to "0"
So far, I have found this, which works to insert a blank row but I cannot figure out how to do the rest:
Dim i As Range
Dim cell As Range
Set i = Range("J:J")
For Each cell In i.Cells
If cell.Value = "XY" Then
cell.EntireRow.Copy
cell.Offset(1).EntireRow.Insert
End If
Next
The above inserts a blank row but I also need to copy and paste the row above its values and change some.
When inserting/deleting rows it's usually best to loop from the bottom up.
That's what the following, simple, example does.
Sub InsertXY()
Dim idx As Long
For idx = Range("J" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("J" & idx).Value = "XY" Then
Rows(idx).Copy
Rows(idx + 1).Insert Shift:=xlDown
Intersect(Rows(idx + 1), Range("G:H, L:L")).Value = 0
End If
Next idx
End Sub
Before
After
I would like to write a code in VBA which copies formula from range("A3:H3") to these columns until there is data in column J. I've tried this code:
Sub fill_up()
If Not IsNull(Range("J3:J30000")) Then
Range("A3:H3").Select
Selection.Copy
Range("A4:H30000").PasteSpecial xlPasteFormulas
End If
End Sub
But this way I get filled up the columns until the 30000. row anyways.
Another code I wrote for a command button:
Private Sub CommandButton1_Click()
Dim i As Integer
Dim j As Integer
i = 3
j = 4
If Not IsEmpty(Cells(i, 9)) Then
Range("A3:H3").Select
Selection.Copy
Cells(j, 1).PasteSpecial xlPasteFormulas
Do until j > 30000
i = i + 1
j = j + 1
Loop
End If
End Sub
But here the formula is only pasted to the 4. row.
Any suggestions?
Something like this:
sub test1()
iRow = 5
Do Until not IsEmpty(cells(iRow,10))
Range(cells(3,1), cells(3,8)).Copy
Range(cells(iRow,1), cells(iRow,8)).PasteSpecial Paste:=xlPasteFormulas
iRow = iRow + 1
Loop
End Sub
That won't copy anything into the row that contains data in col J. If you want to include that row for pasting, then you could add a further single paste op after the do loop as a quick 'n' dirty fix.
I recommend referencing the last cell containing data using ActiveSheet.Usedrange.Rows.Count property.
In your case:
Range("A4:H" & ActiveSheet.UsedRange.Rows.Count)
I was wondering if there was a solution to this just through a formula or shortcuts or if it was something I would need to use VBA for. The spreadsheet I am working with contains 112 rows, 31 columns, and 33 rows containing a "Y" (Y=positive for the purpose of the report this is being used for). I am trying to delete rows that do not contain a single "Y" all the way across the row(columns E-AA) so only the rows and names of people containing a "Y" somewhere in the row are left in the spread sheet. I found a snippet of VBA code from someone else that produced somewhat successful results but didn't include every row with a "Y" (I counted 33 rows containing a Y, the VBA code only showed 14).
The code I was using:
Sub sbDelete_Rows_IF_Cell_Contains_String_Text_Value()
Dim lRow As Long
Dim iCntr As Long
lRow = 112
For iCntr = lRow To 1 Step -1
If Cells(iCntr, 5).Value = "N" Then
Rows(iCntr).Delete
End If
Next
End Sub
The above code produced these results:
The columns of interest containing either a "Y" or "N" in their cells are columns E through AA. If I wasn't clear enough or need to go further into detail just let me know.
This would do the job at hand, even though I'm sure it could be further optimized:
Sub foo()
Dim lRow As Long
Dim iCntr As Long
lRow = 112
For iCntr = lRow To 1 Step -1
For i = 5 To 27 Step 2
If Cells(iCntr, i).Value = "N" Then
Value = Value & " Delete"
Else
Value = Value & " Keep"
End If
Next i
If Not InStr(Value, "Keep") > 0 Then
Rows(iCntr).Delete
End If
Value = ""
Next iCntr
End Sub
To do it using formula, filtering and copy/paste:
Add this formula to each row: =COUNTIF($E2:$AA2,"Y")
This will count the cells containing a single Y on it's own.
Add a filter across your data and filter to exclude 0 on the formula.
Copy and paste the filtered dataset to a new worksheet. You could then clear the original data and re-paste over it. Useful if you're only doing this once.
Edit:
To do the above procedure in VBA (but doing the delete in place rather than move to a second sheet):
Public Sub Test()
Dim rDataRange As Range
'Define range to look at. NB: This is a basic set-up.
'Real scenario would allow user to make selection, or find the limits of the dataset with a FindLastCell function.
Set rDataRange = ThisWorkbook.Worksheets("Sheet1").Range("E1:AA112")
'This block will remove any autofilters that already exist, and then put a formula to the right of the dataset
'to count the Y.
With rDataRange
.Parent.AutoFilterMode = False
.Offset(1, .Columns.Count).Resize(.Rows.Count - 1, 1).FormulaR1C1 = "=COUNTIF(RC5:RC27,""Y"")"
End With
With rDataRange
'This block filters the dataset to only show 0 in the formula.
'The dataset is resized to include the formula.
With .Resize(, .Columns.Count + 1)
.AutoFilter Field:=rDataRange.Columns.Count + 1, Criteria1:="0"
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).EntireRow.Delete 'Resized again to exclude the header.
End With
'The formula and filter are removed.
.Offset(1, .Columns.Count).Resize(.Rows.Count - 1, 1).ClearContents
.Parent.AutoFilterMode = False
End With
End Sub
I'm currently looking for a code to improve my Dashboard. Actually, I need to know how to use a loop in a column X who will affect a column Y (cell on the same line).
To give you an example:
Column A: I have all Production Order (no empty cell)
Column B: Cost of goods Sold (Sometimes blank but doesn't matter)
I actually pull information from SAP so my Column B is not in "Currency".
The action should be:
If A+i is not empty, then value of B+i becomes "Currency".
It's also for me to get a "generic" code that I could use with other things.
This is my current code...
Sub LoopTest()
' Select cell A2, *first line of data*.
Range("A2").Select
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Style = "Currency"
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Another example, getting Last Row, in case your data contains any blank rows.
Sub UpdateColumns()
Dim wks As Worksheet
Dim lastRow As Long
Dim r As Long
Set wks = ActiveSheet
lastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For r = 2 To lastRow
If wks.Cells(r, 1) <> "" Then
wks.Cells(r, 2).NumberFormat = "$#,##0.00"
End If
Next r
End Sub
I can see I was a little slower than the others, but if you want some more inspiration, heer is a super simple solution (as in easy to understand as well)
Sub FormatAsCurrency()
'Dim and set row counter
Dim r As Long
r = 1
'Loop all rows, until "A" is blank
Do While (Cells(r, "A").Value <> "")
'Format as currency, if not blank'
If (Cells(r, "B").Value <> "") Then
Cells(r, "B").Style = "Currency"
End If
'Increment row
r = r + 1
Loop
End Sub
Try the following:
Sub calcColumnB()
Dim strLength As Integer
Dim i As Long
For i = 1 To Rows.Count
columnAContents = Cells(i, 1).Value
strLength = Len(columnAContents)
If strLength > 0 Then
Cells(i, 2).NumberFormat = "$#,##0.00"
End If
Next i
End Sub
Explanation--
What the above code does is for each cell in Column B, so long as content in column A is not empty, it sets the format to a currency with 2 decimal places
EDIT:
Did not need to loop
Here's a really simply one, that I tried to comment - but the formatting got messed up. It simply reads column 1 (A) for content. If column 1 (A) is not empty it updates column 2 (B) as a currency. Changing active cells makes VBA more complicated than it needs to be (in my opinion)
Sub LoopTest()
Dim row As Integer
row = 1
While Not IsEmpty(Cells(row, 1))
Cells(row, 2).Style = "Currency"
row = row + 1
Wend
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