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
Related
The last two days I've been trying to get the resize vba to work.
I need 3 columns (Q,R,S) to be copied and pasted after column 19. This has to happen until the number of 3 column sets (i, copies of Q:S) is equal to the value in cell ("C18"), likewise, if the number of repeats of QRS is greater than the value in C18 the unnecessary copies should be deleted.
The resize worked fine when it was just one column but now that I try to get a set of 3 added or deleted it goes wrong..the number of copies is not equal to the value in ("C18") and the number of copies made or deleted is not constant when I rerun the sub.
Does anyone have a solution?
Sub resize()
Dim SLastCol As Long
Dim i As Long
i = Range("C18").Value * 3
SLastCol = Cells(1, Columns.Count).End(xlToLeft).Column - 19
If SLastCol < i Then
Columns("Q:S").EntireColumn.copy
Columns("T").EntireColumn.Resize(, Abs(SLastCol - i)).Insert shift:=xlToRight
ElseIf SLastCol > i Then
Columns("T:W").EntireColumn.Resize(, Abs(SLastCol - i)).Delete shift:=xlToLeft
End If
Application.CutCopyMode = False
End Sub
Please, test the next code. It will copy all columns in the range colsRng, as many times as is written in "C8":
Sub resizeColumnsCopy()
Dim i As Long, colsRng As Range, lastCol As Long, rngDel As Range, arrCols, arrPrevCols
'identify the previous processed columns and delete them, if any
lastCol = cells(1, Columns.count).End(xlToLeft).Column
arrPrevCols = Range(cells(1, 20), cells(1, lastCol)).Value 'place the headers after column 20 in an array
arrCols = Range("Q1:S1").Value 'do the same with the copied columns headers
For i = 1 To UBound(arrPrevCols, 2) Step 3 'iterate in the larger array, from three to three columns
If arrPrevCols(1, i) = arrCols(1, 1) Then 'finding the first column header
If rngDel Is Nothing Then
Set rngDel = Range(cells(1, 19 + i), cells(1, 19 + i + 2)) 'create a range of the three involved columns
Else
Set rngDel = Union(rngDel, Range(cells(1, 19 + i), cells(1, 19 + i + 2))) 'careate a Union between the previous range and the next three
End If
End If
Next i
If Not rngDel Is Nothing Then rngDel.EntireColumn.Delete 'if cases of processed columns found, then delete the columns
i = Range("C18").Value
Set colsRng = Columns("Q:S")
colsRng.Copy
cells(1, colsRng.Column + colsRng.Columns.count).EntireColumn.resize(, i * colsRng.Columns.count).Insert Shift:=xlToRight
Application.CutCopyMode = False
End Sub
But, please edit your question and explain about the necessity of previous processed columns deletion. Otherwise, somebody else looking to my code will think that I recently hit my head...
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
I am trying to read all values in column G until it finds a blank cell. If values are "Permits Received" or "Cancelled" then I write "Ready to Build" in column H. If I encounter anything other than received or cancelled then I write "Missing Permits". So, I need to read ALL populated cells in column G and write ready... or missing... in column H. The problem with my code is 1) its probably not the best approach, and 2) it only reads the first cell in column G then writes the output.
This is for an automated workbook that works like a champ except for this loop. I have been goofing with For Next, Do While and For Each with varying success but the code below is the closest I've been.
Dim i As Integer, j As Integer, rng As Range
Set rng = Range("$G$2:$G$" & ActiveSheet.UsedRange.Rows.Count) ' Set range to all used rows in column G
For i = 2 To rng.Rows.Count
Do While Cells(i, 7).Value = ""
If Cells(i + 1, 7).Value = "Permits Received" Or Cells(i + 1, 7).Value = "Cancelled" Then
Cells(i, 8).Value = "Ready to Build"
Else: Cells(i, 8).Value = "Missing Permits"
End If
i = i + 1
If i = rng.Rows.Count Then Exit For ' Without this code it will read all rows, not just used rows
Loop
Next i
I expect the loop to read all column G values then decide if it is "Ready to Build" or "Missing Permits". The code runs to the 35766 then errs with Overflow if the Exit For is not included.
(new) I only need one output line (col H) per each line or group of lines (col G). The attached image shows how the output should look. Thank you so, so much for looking at this!!! I've been staring at it for a week!
Example of input and correct output, need code for column H
Example of output from latest solution
Solution based on the image published:
Assuming that the default value for any FIB:BUR group is "Missing Permits", unless all of its FIB:PERMITs have the values "Permits Received" or "Cancelled" then it should be marked as "Ready to Build".
This proposed solution uses AutoFilter object (Excel) combined with the Range.SpecialCells method (Excel). To create a range in which the groups are separated by Range.Areas property (Excel).
Then it uses For…Next and the WorksheetFunction.CountIf to validate the presence of "Permits Received" or "Cancelled", and Range.Offset Property (Excel) to set the resulting value for the group.
Sub Solution()
Dim rSrc As Range, rTrg As Range
Dim rArea As Range
Dim bCnt As Byte 'Change data type to long if the number of FIB:PERMITs by FIB:BUR exceeds 255
With ThisWorkbook.Worksheets("DATA") 'change as required
If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
Set rSrc = .Cells(2, 7).Resize(-1 + .UsedRange.Rows.Count, 2)
End With
With rSrc
.Columns(2).ClearContents
.Offset(-1, 0).Resize(1 + .Rows.Count).AutoFilter
.AutoFilter Field:=1, Criteria1:="<>"
Set rTrg = .Columns(1).SpecialCells(xlCellTypeVisible)
.AutoFilter
End With
For Each rArea In rTrg.Areas
bCnt = 0
With WorksheetFunction
bCnt = .CountIf(rArea, "Cancelled")
bCnt = bCnt + .CountIf(rArea, "Permits Received")
rArea.Cells(1).Offset(-1, 1).Value2 = _
IIf(bCnt = rArea.Rows.Count, "Ready to Build", "Missing Permits")
End With: Next
End Sub
Answer to original question
Instead of using a Do…Loop within the For…Next, you could have used IF…ELSEIF or Select Case statement. This proposed solution uses Select Case
Sub Solution_1()
Dim rTrg As Range, lRow As Long
With ThisWorkbook.Worksheets("DATA") 'change as required
Set rTrg = .Cells(2, 7).Resize(-1 + .UsedRange.Rows.Count, 2)
End With
With rTrg
For lRow = 1 To .Rows.Count
Select Case .Cells(lRow, 1).Value2
Case vbNullString 'NO ACTION!
Case "Permits Received", "Cancelled"
.Cells(lRow, 2).Value2 = "Ready to Build"
Case Else
.Cells(lRow, 2).Value2 = "Missing Permits"
End Select: Next: End With
End Sub
However, I try to avoid For…Next whenever is possible, so this alternate solution uses
AutoFilter object (Excel) combined with the Range.SpecialCells method (Excel).
Sub Solution_2()
Dim rTrg As Range
With ThisWorkbook.Worksheets("DATA") 'change as required
If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
Set rTrg = .Cells(2, 7).Resize(-1 + .UsedRange.Rows.Count, 2) ' Set range to all used rows in column G
End With
With rTrg
.Offset(-1, 0).Resize(1 + .Rows.Count).AutoFilter
.Columns(2).Value2 = "!"
.AutoFilter Field:=2, Criteria1:="!"
.AutoFilter Field:=1, Criteria1:="=Cancelled", _
Operator:=xlOr, Criteria2:="=Permits Received"
.Columns(2).SpecialCells(xlCellTypeVisible).Value2 = "Ready to Build"
.AutoFilter Field:=1, Criteria1:="<>"
.Columns(2).SpecialCells(xlCellTypeVisible).Value2 = "Missing Permits"
.AutoFilter Field:=1
.Columns(2).SpecialCells(xlCellTypeVisible).ClearContents
.Cells(1).AutoFilter
End With
End Sub
I've encountered a similar issue when using a for loop to iterate rows like that when I use an integer as the data type for my loop index variable. The Excel integer data is 2-bytes in length and has a range of -32,768 to 32,767. Perhaps your mention of "35766" was a typo for 32766 or 32767. If you change your variable 'i' from an int to a long, I would expect your issue to go away.
If this macro is something for your personal use rather than something others will be using, I've often used the following approach to iterate down one column and modify another cell that's on the same row:
Do While IsEmpty(ActiveCell.value) = False
If ActiveCell.value = "X" Then
ActiveCell.Offset(0, 1).value = "M" ' ActiveCell.Offset(row_offset, column_offset)
ElseIf ActiveCell.value = "Y" Then
ActiveCell.Offset(0, 1).value = "N"
End If
ActiveCell.Offset(1, 0).Activate ' From currently active cell, activate the next cell one row down
Loop
Before running a macro using this technique, you'd have to activate the first cell in the column being evaluated - which becomes the cell first evaluated as the ActiveCell.
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 have a spreadsheet with a bunch of data all in one column and I'm looking to pull out specific data. I'm trying to see if a 'do until loop' will work.
I'm trying to get the loop to stop when it see "directory*" as part of the cell for example Directory of G:\Example. Until then the loop should look through the Cells and if it doesn't start with a number copy that cell to another sheet/column.
Sub Order()
iRow = 1
Do Until Cells(iRow, 1) = "Directory*"
If Cells(iRow, 1) <> NumberatBeginning Then
Cells(iRow, 1).Copy _
Destination:=Worksheets("Sheet2").Range("A1")
End If
iRow = iRow + 1
Loop
End Sub
Any help would be appreciated
You're almost there, the IsNumeric function can be used in conjunction with the Mid (or Left) function to check the first character in the cell value and return True or False if the character is numeric. Try this:
Sub Order()
Dim iRow as Long, x as Long
iRow = 1
x = 1
Do Until Cells(iRow, 1).Value Like "Directory*"
If Not IsNumeric(Mid(Cells(iRow, 1).Value, 1, 1)) Then
Worksheets("Sheet2").Cells(x, 1).Value = Cells(iRow, 1).Value
x = x + 1
End If
iRow = iRow + 1
Loop
End Sub
You should avoid using copy and paste as it slows down code, it is always better to simply set the value of the cell.
Also, when you're looping through and copying the cells with non-numeric first characters and pasting them into Sheet2 your code is always pasting into the same cell, Range("A1"), assuming you want a list of the values you will need to increment this by adding a row each time a value is copied to Sheet2.