The code below works but does not copy over rows with blank cells, for example "Sheet1" has a total of 35 rows and 56 columns but certain cells are blank e.g. cell A28 & A31, this means the code will copy and paste 33 rows in "Sheet2" which excludes rows 28 and 31 instead of all 35 rows.
How can I change this to copy all 35 rows irrespective of whether it has blank cells or not?
My objective is to copy 10 specific columns for all 35 rows from "Sheet1" which has 56 columns to "Sheet2" which is currently blank and in different column order. Hope this makes sense.
Sub Transfer_Macro ()
'
Dim lastrow As Long, erow As Long
lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
Worksheets("Sheet1").Cells(i, 1).Copy
erow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Sheet1").Paste Destination:=Worksheets("Sheet2").Cells(erow + 1, 1)
Worksheets("Sheet1").Cells(i, 3).Copy
Worksheets("Sheet1`").Paste Destination:=Worksheets("Sheet2").Cells(erow + 1, 3)
Next i
End Sub
Assuming Luis Curado has diagnosed your problem correctly, you can find the larger of the last cell row in A and C.
Also you had some confused syntax here
Worksheets("Sheet1").Paste Destination:=Worksheets("Sheet2").Cells(erow + 1, 1)
Finally, you can transfer the values without involving the clipboard.
Sub Transfer_Macro()
Dim lastrow As Long, erow As Long
With Worksheets("Sheet1")
lastrow = WorksheetFunction.Max(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(Rows.Count, 3).End(xlUp).Row) 'could use Find instead for this
For i = 2 To lastrow
erow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Sheet2").Cells(erow + 1, 1).Value = .Cells(i, 1).Value
Worksheets("Sheet2").Cells(erow + 1, 3).Value = .Cells(i, 3).Value
Next i
End With
End Sub
Note that if you are copying blank cells, the last row will not update.
Related
I have an excel file with 3 sheets inside:
Starting Date and Ending Date in Sheet1 (1st screenshot)
A database in Sheet2 (2nd screenshot)
Filtered data in Sheet3 based on the date in Sheet1 (3rd screenshot)
I have a script that copy the data from Sheet2 to Sheet3 based on the date in Sheet1. I want the script to be able to put a zero in the empty space if it is detected instead of leaving it as blank.
For example, in the 2nd screenshot above, there is no value in Row 8 for Group 4 and Group 6, so I want the script to be able to put a zero in Group 4 and Group 6 for Row 8 when the data is copied to Sheet3.
I managed to achieve this but some how there will be zero in Row 9 as well (shown in the 3rd screenshot). There should be no zero in Row 9 since the date in Sheet1 is only from December-20 to February-21 (3 months). May I know how should I modified my script so that I'm able to eliminate the zero in Row 9? Any help will be greatly appreciated!
This is my script:
Sub extractdata()
Dim LastRow As Long, erow As Long, i As Long, j As Long, LastRow2 As Long
Dim mydate As Date
LastRow2 = Sheet3.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
Sheet3.Range("B6:H" & LastRow2).ClearContents
LastRow = Sheet2.Cells(Rows.Count, 2).End(xlUp).Row
For i = 6 To LastRow
mydate = Sheet2.Cells(i, 2)
If mydate >= Sheet1.Cells(7, 19) And mydate <= Sheet1.Cells(8, 19) Then
erow = Sheet3.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
Sheet2.Range(Sheet2.Cells(i, 2), Sheet2.Cells(i, 57)).Copy Destination:=Sheet3.Cells(erow, 2)
End If
For j = 3 To 8
If IsEmpty(Sheet3.Cells(i, j).Value) = True Then
Sheet3.Cells(i, j) = 0
End If
Next j
Next i
End Sub
Edit
Sub extractdata()
Dim LastRow As Long, erow As Long, i As Long, j As Long, LastRow2 As Long
Dim mydate As Date
LastRow2 = Sheet3.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
Sheet3.Range("B6:H" & LastRow2).ClearContents
LastRow = Sheet2.Cells(Rows.Count, 2).End(xlUp).Row
For i = 6 To LastRow
mydate = Sheet2.Cells(i, 2)
If mydate >= Sheet1.Cells(7, 19) And mydate <= Sheet1.Cells(8, 19) Then
erow = Sheet3.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
Sheet2.Range(Sheet2.Cells(i, 2), Sheet2.Cells(i, 57)).Copy Destination:=Sheet3.Cells(erow, 2)
End If
Next i
ZeroIsteadBlank
End Sub
I call the function after For loop, but this is what I get:
Row 9 still exist with bunch of zero with additional date in Cell B9
Please, use this code at the end. Iterating during the copying code is waste of time and Excel resources:
Sub ZeroIsnteadBlank()
Dim sh As Worksheet, rngEmpty As Range, LastRow2 As Long
Set sh = Sheet3
LastRow2 = sh.Cells(Rows.Count, 2).End(xlUp).Row + 1 '+ 1 for an extra row...
On Error Resume Next 'Otherwise, the following line will return an error in case of no empty cells...
Set rngEmpty = sh.Range("C6:H" & LastRow2).SpecialCells(xlCellTypeBlanks)
If Not rngEmpty Is Nothing Then
rngEmpty.value = 0
Else
MsgBox "No empty cells..."
End If
On Error GoTo 0
End Sub
In order to avoid the case of an empty cell of the column C:C (C8 in your example), it should be good to calculate LastRow2 for two columns and choose the bigger one...
If cell in column I1-I14 is greater than cell in column J1-J14, I want to cut the entire row and paste values to the first empty row. (From row 16 and down.)
If cell i is greater than cell j, cut row and paste values to first empty row (row 16 in this example)
This code just pastes in the first row:
Sub Knapp6_Klicka()
Dim i As Long
Dim j As Long
j = 1
For i = 3 To 500
If Cells(i, 9).Value > Cells(i, 10).Value Then
Cells(i, 12).EntireRow.Cut Sheets("Blad1").Range("A" & j)
j = j + 1
End If
Next i
End Sub
I tried to combine the paste with two different solutions.
One like this, where I recorded a macro and went to the last cell, then up to the first empty cell:
Range("A1048576").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
And one solution that I found on an Excel community:
Sub compareresult()
Dim row1 As Integer
Dim row2 As Integer
row2 = 1
For row1 = 8 To 500
If sheet1.Cells(row1, 11).value > sheet1.Cells(row1, 9).value Then
sheet1.Cells(row1, 1).EntireRow.Copy Sheets(11).Cells(row2, 1)
row2 = row2 + 1
End If
Next row1
End Sub
If cell in column I1-I14 is greater than cell in column J1-J14, i want to cut entire row and paste values to the first empty row. (From row 16 and down)
Here is a method which doesn't cut and paste in a loop. Since you are not deleting the row or "cutting and inserting" the row, here is a simple approach. The below code follows a basic logic
Logic
Loop and identify the range.
If found, then copy the range in 1 go.
Finally clear the range which was copied (if copied).
Code
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rngToCopy As Range
Dim i As Long
'~~> Change this to relevant sheet
Set ws = Sheet1
With ws
'~~> Loop and identify the range
For i = 2 To 14
If .Range("I" & i).Value2 > .Range("J" & i).Value2 Then
If rngToCopy Is Nothing Then
Set rngToCopy = .Rows(i)
Else
Set rngToCopy = Union(rngToCopy, .Rows(i))
End If
End If
Next i
'~~> If found then copy and clear
If Not rngToCopy Is Nothing Then
rngToCopy.Copy .Rows(16)
rngToCopy.Clear
End If
End With
End Sub
EDIT:
To incorporate new edits
Works perfectly! Thanks! :) I failed to fully describe my problem.. What i also need is to paste it as special (only paste the value and not the formulas). Do you got any quick solution for that? – Johl 5 hours ago
Replace
rngToCopy.Copy .Rows(16)
to
rngToCopy.Copy
DoEvents
.Rows(16).PasteSpecial Paste:=xlPasteValues
Have a try with this.
It's based on the range you gave. Skipped over row 1 since you have headers in it.
Dim i As Long, lRow As Long, ws As Worksheet
Set ws = Sheets("Blad1") 'Your sheet name
lRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1 'Finding the last row
If lRow < 16 Then lRow = 16 'The starting row you want to cut to
For i = 2 To 14 'Your range of rows to check
If ws.Range("I" & i) > ws.Range("J" & i) Then
ws.Range("I" & i).EntireRow.Cut ws.Range("A" & lRow) 'Cutting the whole row so you use column A to cut to
lRow = lRow + 1 'Move down 1 row for where to cut to
End If
Next i
Edit:
Because you only want the values to copy accross we can't use Cut and PasteSpecial xlValues so instead we will duplicate the value of the entire row to the new location, then clear the row (filling in for the cutting part). If clear is too much we can just ClearContents to remove the values in the cells instead of the formatting if that happens. Make sure to always save before running VBA code for the first time.
Dim i As Long, lRow As Long, ws As Worksheet
Set ws = Sheets("Blad1") 'Your sheet name
lRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1 'Finding the last row
If lRow < 16 Then lRow = 16 'The starting row you want to cut to
For i = 2 To 14 'Your range of rows to check
If ws.Range("I" & i) > ws.Range("J" & i) Then
ws.Range("A" & lRow).EntireRow.Value = ws.Range("I" & i).EntireRow.Value 'Copying the values over
ws.Range("I" & i).EntireRow.Clear 'Clear the row
lRow = lRow + 1 'Move down 1 row for where to cut to
End If
Next i
Your code is doomed to failure because you do not take into consideration that you are cutting the found row. Think about what that means. Your row with the In,Out is row 15 and you wish to paste to row 16. If you cut row 5 (for example) then rows 15 and 16 will become rows 14 and 15. It also means that your next row (which you think will be row 6) will actually be what was row 7 before the cut.
I want to copy paste values from 4 columns in one worksheet into 4 columns of another worksheet depending on whether the values in a single column are null or not.
Following is my code:
Private Sub CommandButton1_Click()
Dim lastrow As Long, erow As Long
lastrow = Worksheets("jun").Cells(Rows.Count, 1).End(xlUp).Row
erow = 20
For i = 8 To lastrow
If Worksheets("jun").Cells(i, 16).Value <> "" Then
Worksheets("jun").Cells(i, 16).Copy
Worksheets("jun").Paste Destination:=Worksheets("test").Cells(erow + 1, 1)
Worksheets("jun").Cells(i, 3).Copy
Worksheets("jun").Paste Destination:=Worksheets("test").Cells(erow + 1, 2)
Worksheets("jun").Cells(i, 2).Copy
Worksheets("jun").Paste Destination:=Worksheets("test").Cells(erow + 1, 3)
Worksheets("jun").Cells(i, 6).Copy
Worksheets("jun").Paste Destination:=Worksheets("test").Cells(erow + 1, 4)
erow = erow + 1
End If
Next i
End Sub
However this code produces an error when I try to paste the values into the second column of the test worksheet and I suspect this is because it is made of a merged column.
Following is the picture that shows the merged column. How could I combat this issue?
Having experimented slightly it appears .PasteSpecial Paste:=xlPasteValues will cause an error pasting into merged cells but .PasteSpecial Paste:=xlPasteValuesAndNumberFormats can paste into merged cells without that error
Try the updated sub below:
please note a slight alteration to the paste columns to take into account the merged column. I have also adjusted erow so it starts at 21 to avoid having to use 'erow + 1' for all entries
Private Sub CommandButton1_Click()
Dim lastrow As Long, erow As Long
With Worksheets("jun")
erow = 21
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 8 To lastrow
If .Cells(i, 16).Value <> "" Then
.Cells(i, 16).Copy
Worksheets("test").Cells(erow, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Cells(i, 3).Copy
Worksheets("test").Cells(erow, 2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Cells(i, 2).Copy
Worksheets("test").Cells(erow, 4).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Cells(i, 6).Copy
Worksheets("test").Cells(erow, 5).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
erow = erow + 1
End If
Next i
End With
End Sub
Is this the line causing the issue?
Worksheets("jun").Paste Destination:=Worksheets("test").Cells(erow + 1, 3)
It sounds like you're trying to paste in the third column but when you merge columns, the left most column becomes the primary. For example, you've merged B&C (cols 2 and 3) so any reference to 3 is now redundant. You'd either paste in to column 2 or 4. With that row, if you're trying to paste in to column D, you'd need to reference column 4, not 3.
I am attempting to copy column B from sheet called "Activity Overview" (Only filled cells) and paste in a sheet called "V&VFile" in column E from row 11 onwards, however when i run the macro the cells arent copied and seems to paste blank cells.
The source of the data uses excel formula index match, is this why as it can copy the data as its found from an excel formula?
Sub VVfileFILL()
Dim Lastrow As Double
Lastrow = Worksheets("Activity Overview").Cells(Rows.Count, "B").End(xlUp).Row
ThisWorkbook.Worksheets("Activity Overview").Range("B" & Lastrow).Copy
ThisWorkbook.Sheets("V&V").Range("E" & Rows.Count).End(xlUp).Offset(10, 0).PasteSpecial xlPasteValues
End Sub
Don't think one can avoid a loop in this situation.
Sub VVfileFILL()
Dim Lastrow As Long, r As Long, n As Long
n = Worksheets("V&V").Range("E" & Rows.Count).End(xlUp).Offset(10, 0).Row
With Worksheets("Activity Overview")
Lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
For r = 2 To Lastrow
If Len(.Cells(r, "B")) > 0 Then 'check not blank
If WorksheetFunction.CountIf(Worksheets("V&V").Range("E1:E" & n), .Cells(r, "B")) = 0 Then 'check not already in E
Worksheets("V&V").Cells(n, "E").Value = .Cells(r, "B").Value 'transfer value
n = n + 1 'add 1 to destination row
End If
End If
Next r
End With
End Sub
I have a row of cells (the row elements may vary) and another sheet with several columns of data. Let's say on sheet 1 we have 7 columns with data(first column with titles) and on sheet 2 we have some of those titles transposed on the first row. The task is to find all possible values for each title in sheet 2. Let's say in sheet 2 on the first cell we have title X, then I need to find all values corresponding to title X in sheet 1 and to take out the results from the 8th column of sheet 1. then do the same for cell 2 in sheet 2 and so on till the end of the row.
Can someone share a hint or any suggestions that might help me.
Actually I used the following code:
Sheets("sheet2").Select
Dim Lcola As Long
Dim rng As Range
With ActiveSheet
Lcola = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(2, 1), .Cells(2, Lcola))
With rng
Range("A2").Select
ActiveCell.Formula = "=VLOOKUP(A$1,MAP!$A$1:$I$" & lRowc & _
",8,FALSE)"
Selection.AutoFill Destination:=rng, Type:=xlFillDefault
End With
End With
The thing is that I'm not sure how to repeat the function several times, or as much repetitions as I have on each variable from sheet 2 in sheet 1. And another issue that I'm facing is the vlookup function always gives me the first found item.
Use a For loop, with your last Column from Sheet2 as your counter Max.
use iCol to keep track of which Column on Sheet2 you are copying and reading from.
use iRow to keep track of which ROW has the data you want on Sheet1.
Since you know you need the 8th column on the Sheet 1, it will always be Sheets("Sheet1"),Cells(iRow, 8)
and since you know the ROW that the column headers are located in Sheet2, Sheets("Sheet2"),Cells( 1, iCol) - if the header row is 1.
Then just grab a LastRow check on the Sheet2 Column in question and add to it one at a time.
Dim iCol As Integer
Dim lastCol As Integer
Dim lastRow1 As Integer
Dim lastRow2 As Integer
Dim matchRow As Integer
Dim tempVal As String
Dim iRow As Integer
Dim nRow As Integer
Private Sub IndexMatchLoop()
lastCol = Sheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Column
For iCol = 1 To lastCol
'Assuming your row on Sheet2 is 1.
tempVal = Sheets("Sheet2").Cells(1, iCol)
iRow = 1
Call GetLastRow
nRow = lastRow2 + 1
'Looks up the value from Sheet2 Column Header on Column1 of Sheet1 one Row at a Time
For iRow = 1 to lastRow1
If Sheets("Sheet1").Cells(iRow, 1) = tempVal Then
'Copy the data from Sheet1 Column 8 in the Rows with the value to Sheet2, the nextRow of the Col
Sheets("Sheet2").Cells(nRow, iCol) = Sheets("Sheet1").Cells(iRow, 8)
nRow = nRow + 1
End If
Next iRow
Next iCol
End Sub
Private Sub GetLastRow()
lastRow1 = Sheets("Sheet1").Cells(65532, 1).End(xlUp).Row
lastRow2 = Sheets("Sheet2").Cells(65532, iCol).End(xlUp).Row
End Sub
EDIT: typo in formula (was relying on autoComplete for "Int" instead of "Integer"
EDIT: Adding Screenshots