'Sub CopyRowToSheet23()
Worksheets("Sheet2").Range("A2:E1000").Clear
Dim LastRowSheet1, LastRowSheet2 As Long
Dim i As Long
Application.ScreenUpdating = False
LastRowSheet2 = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet2").Range("A2:E" & LastRowSheet2).ClearContents
LastRowSheet1 = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
With Worksheets("Sheet1")
For i = 2 To LastRowSheet1 Step 1
If Cells(i, "E").Value = "YES" Then
LastRowSheet2 = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
Rows(i).Copy Worksheets("Sheet2").Range("A" & LastRowSheet2 + 1)
End If
Next i
End With
Application.ScreenUpdating = True
Sheet3.Select
End Sub'
I´ve managed to create the code above to get all rows that have "yes" in column E. However, I´m having issues when trying to run the macro in other sheets different than Sheet1. I would like to run it in sheet3 but I haven´t found why it does not help.
Try:
Option Explicit
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim wsRE As Long, i As Long, LastrowC As Long, LastrowE As Long, LastrowF As Long
'Set ws1
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
'Set ws2
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
wsRE = ws2.Cells(ws2.Rows.Count, "E").End(xlUp).Row
'Starting from Row 2 - let us assume that their is a header
For i = 2 To wsRE
'Check if the value in column E is yes
If ws2.Range("E" & i).Value = "Yes" Then
'Find the Last row in Sheet1 Column C
LastrowC = ws1.Cells(ws1.Rows.Count, "C").End(xlUp).Row
'Copy row i, Column A from Sheet 1 and paste it in Sheet 2 after the lastrow in column C
ws2.Range("A" & i).Copy ws1.Cells(LastrowC + 1, 3)
'Find the Last row in Sheet1 Column E
LastrowE = ws1.Cells(ws1.Rows.Count, "E").End(xlUp).Row
'Copy row i, Column B from Sheet 1 and paste it in Sheet 2 after the lastrow in column E
ws2.Range("B" & i).Copy ws1.Cells(LastrowE + 1, 5)
'Find the Last row in Sheet1 Column F
LastrowF = ws1.Cells(ws1.Rows.Count, "F").End(xlUp).Row
'Copy row i ,Column C from Sheet 1 and paste it in Sheet 2 after the lastrow in column F
ws2.Range("C" & i).Copy ws1.Cells(LastrowF + 1, 6)
End If
Next i
End Sub
Related
I am trying to copy data from wsSource to wsDestination if the data doesn't exist in wsDestination. The data copies if the data doesn't exist but it copies to the last row rather than the next empty row.
I have attached screen shots to illustrate this
Screenshot showing data from wsDestination before any copy is done
Screenshot showing data in wsSource
Screenshot showing data in wsDestination after data has been copied
Sub test()
Dim wsSource As Worksheet, wsDestination As Worksheet
Dim LastRowSource As Long, LastRowDestination As Long
Dim i As Long, y As Long
Dim Value_1 As String, Value_2 As String, Value_3 As String
Dim ValueExists As Boolean
With ThisWorkbook
Set wsSource = .Worksheets("Data Source")
Set wsDestination = .Worksheets("Data Destination")
End With
With wsSource
'Find the last row of Column C, wsSource
LastRowSource = .Cells(.Rows.Count, "C").End(xlUp).Row
'Loop Column C, wsSource
For i = 13 To LastRowSource
'Data to be tested if it doesn't exist in wsDestination
Value_1 = .Range("B" & i).Value
Value_2 = .Range("C" & i).Value
Value_3 = .Range("D" & i).Value
ValueExists = False
With wsDestination
'Find the last row of Column B, wsDestination
LastRowDestination = .Cells(.Rows.Count, "B").End(xlUp).Row
'Loop Column B, wsDestination
For y = 5 To LastRowDestination
'Check to see whether data exists
If .Range("B" & y).Value = Value_1 Then
ValueExists = True
Exit For
End If
Next y
'If data doesn't exist in wsDestination then copy data to next available row
If ValueExists = False Then
.Range("B" & y).Value = Value_1
.Range("C" & y).Value = Value_2
.Range("D" & y).Value = Value_3
End If
End With
Next i
End With
End Sub
Screenshot 4 showing results after amended code
If I unterstood your problem, you always want to fill the next empty range on the destination sheet. First of all check this line:
For y = 5 To LastRowDestination
This loop will start from row number 5 which is the header row on the destination sheet. You don't want to accidentally overwrite it, so you start the loop from the 6th row like this:
For y = 6 To LastRowDestination
This line will check your rows to the last row on your destination sheet. So if every empty row has been filled, it will go to your last (not empty) row:
LastRowDestination = .Cells(.Rows.Count, "B").End(xlUp).Row
You want to check + 1 row (it will be a guaranteed empty row).
LastRowDestination = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
You don't need ValueExists flag, you can check if a range is empty like this:
If WorksheetFunction.CountA(.Range("B" & y & ":D" & y)) = 0 Then ' EMPTY RANGE
So here is the cleaned up version of your code:
Sub test()
Dim wsSource As Worksheet, wsDestination As Worksheet
Dim LastRowSource As Long, LastRowDestination As Long
Dim i As Long, y As Long
With ThisWorkbook
Set wsSource = .Worksheets("Data Source")
Set wsDestination = .Worksheets("Data Destination")
End With
With wsSource
'Find the last row of Column C, wsSource
LastRowSource = .Cells(.Rows.Count, "C").End(xlUp).Row
'Loop Column C, wsSource
For i = 13 To LastRowSource
With wsDestination
'Find the last row of Column B, wsDestination
LastRowDestination = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
'Data to be tested if it doesnt exist in wsDestination
'if IsError is true, data does not exist in wsDestination
If IsError(Application.VLookup(.Range("B" & i), .Range("B6:B" & LastRowDestination), 1, False)) Then
'Loop Column B, wsDestination
For y = 6 To LastRowDestination
'Check to see whether data existsd
If WorksheetFunction.CountA(.Range("B" & y & ":D" & y)) = 0 Then ' EMPTY RANGE
.Range("B" & y) = wsSource.Range("B" & i)
.Range("C" & y) = wsSource.Range("C" & i)
.Range("D" & y) = wsSource.Range("D" & i)
Exit For
End If
Next y
End If
End With
Next i
End With
End Sub
I'm using the below code. My goal is to change this row:
cell.EntireRow.Copy Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
If the number in Sheet1 A2 matches Sheet2 A2
Then copy the data from Sheet1 P2 to Sheet2 P2
(and consecutively if Sheet1 A3 = Sheet2 A3 THEN copy Sheet1 P3 to Sheet2 P3 all the way down the list).
Sub Sheet1Sheet2Compare()
Dim lRow, x As Long
Sheets("Sheet1").Select
lRow = Range("A1").End(xlDown).Row
For Each cell In Range("A2:A" & lRow)
x = 2
Do
If cell.Value = Sheets("Sheet2").Cells(x, "A").Value Then
cell.EntireRow.Copy Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
x = x + 1
Loop Until IsEmpty(Sheets("Sheet2").Cells(x, "A"))
Next
End Sub
try this
Sub Sheet1Sheet2Compare()
Dim lRow As Integer, x As Integer, i As Integer
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
lRow = sht1.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lRow
If sht1.Range("A" & i).Value = sht2.Range("A" & i).Value Then sht2.Range("P" & i).Value = sht1.Range("P" & i).Value
Next i
End Sub
I'm trying to display the contents of a merged cell in a For loop in Excel using VBA.
I have the a worksheet with very simple data in it
Here is my code:
'finding last record in my initial list
sheet_last_row = Sheets("mylist").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To sheet_last_row
last_row = Sheets("results").Cells(Rows.Count, 1).End(xlUp).Row
If Sheets("mylist").Cells(i, 1).Value = 2 Then
'test if cell is merged
If Sheets("mylist").Cells(i, 2).MergeCells Then
RowCount = Sheets("mylist").Cells(i, 2).Value
End If
Sheets("mylist").Cells(i, 1).EntireRow.Copy Sheets("results").Cells(last_row + 1, 1)
End If
Next i
I'm getting the following result with this code;
I'm new at this. Can anyone show me how to make this work.
You could try:
Option Explicit
Sub test()
Dim LastRowA As Long, LastRowB, LastRowC As Long, LastRowE As Long, MaxRow As Long
Dim cell As Range, rng As Range
With ThisWorkbook.Worksheets("Sheet1")
'Find the lastrow for all the available columns
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
LastRowB = .Cells(.Rows.Count, "B").End(xlUp).Row
LastRowC = .Cells(.Rows.Count, "C").End(xlUp).Row
'Get the longer last row in order to avoid losing data if the last cell of a column is merge or empty
MaxRow = WorksheetFunction.Max(LastRowA, LastRowB, LastRowC)
'Set the area to loop
Set rng = .Range("A2:C" & MaxRow)
'Start looping
For Each cell In rng
'If the cell is merger
If cell.MergeCells Then
'Find the last row of column E
LastRowE = .Cells(.Rows.Count, "E").End(xlUp).Row
'Paste cell value in column E
.Range("E" & LastRowE + 1).Value = cell.Value
'Paste cell address in column F
.Range("F" & LastRowE + 1).Value = cell.Address
End If
Next
End With
End Sub
Results:
I have one sheet of data where I need to extract the values from multiple columns and assign them a value. Column A is a string where column B is the assigned value. Columns C and D are vlookups based on column A and they will need the assigned value from column B as well. Please see the screenshots. I would need to compile a list on a separate sheet. Ideally column A would have the data from columns A, C and D from the other sheet and column B would have the assigned values. Only caveat is I need to exclude any row that has #N/A
Any macro that may work would be very helpful!
Code I was using
Sub Life_Saver_Button()
Dim lastrow As Long, erow As Long
Set S1 = Worksheets("Sheet1")
Set S2 = Worksheets("Sheet2")
lastrow = ThisWorkbook.Sheets("S1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
S1.Cells(i, 1).Copy
erow = ThisWorkbook.Sheets("S2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ThisWorkbook.Sheets("S1").Paste Destination:=ThisWorkbook.Sheets("S2").Cells(erow, 1)
ThisWorkbook.Sheets("S1").Cells(i, 2).Copy
ThisWorkbook.Sheets("S1").Paste Destination:=ThisWorkbook.Sheets("S2").Cells(erow, 2)
ThisWorkbook.Sheets("S1").Cells(i, 3).Copy
ThisWorkbook.Sheets("S1").Paste Destination:=ThisWorkbook.Sheets("S2").Cells(erow, 1)
ThisWorkbook.Sheets("S1").Cells(i, 4).Copy
ThisWorkbook.Sheets("S1").Paste Destination:=ThisWorkbook.Sheets("S2").Cells(erow, 2)
ThisWorkbook.Sheets("S1").Cells(i, 5).Copy
ThisWorkbook.Sheets("S1").Paste Destination:=ThisWorkbook.Sheets("S2").Cells(erow, 1)
ThisWorkbook.Sheets("S1").Cells(i, 5).Copy
ThisWorkbook.Sheets("S1").Paste Destination:=ThisWorkbook.Sheets("S2").Cells(erow, 2)
Next i
Application.CutCopyMode = False
ThisWorkbook.Sheets("S2").Columns().AutoFit
Range("A1").Select
End Sub
Try:
Option Explicit
Sub test1()
Dim LastrowA As Long, Lastrow As Long, cell As Range, Code As Long
Dim Desc As String
With ThisWorkbook.Worksheets("Sheet1")
LastrowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A1:D" & LastrowA)
If Not IsError(cell.Value) = True And Not IsNumeric(cell.Value) = True Then
Desc = cell.Value
Code = .Range("B" & cell.Row).Value
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
If LastrowA = Lastrow Then
.Range("A" & Lastrow + 2).Value = Desc
.Range("B" & Lastrow + 2).Value = Code
Else
.Range("A" & Lastrow + 1).Value = Desc
.Range("B" & Lastrow + 1).Value = Code
End If
End If
Next
End With
End Sub
Results:
I need a macro to write the row values present in column A if there is a value present in column B .
For example :
Column A Column B
Arjun
Arun 12
For the above example, I need a macro which can write "Arun 12" in Sheet2 of the work book with the Headers "Name" and "Hours".Before this the macro should clear the data present in Sheet two completely.
This will copy the all rows of columns A and B from Sheet1 to Sheet2 if B is not a Null string. And also will add the headers "Name" and "Hours".
Option Explicit 'requires that every variable has to be defined before use, e.g. with a Dim statement.
Sub DoStuff_GoodPractice()
Dim lastRowSrc As Long, lastRowDest As Long, i As Long 'declare row counts as Long so all rows can be used
Dim shtSource As Worksheet, shtDestination As Worksheet
Set shtSource = ThisWorkbook.Worksheets("Sheet1") 'full qualified identification of the worksheets
Set shtDestination = ThisWorkbook.Sheets("Sheet2")
lastRowSrc = shtSource.Range("A" & shtSource.Rows.Count).End(xlUp).Row 'determine the last used row
'clear destination sheet and write headers:
shtDestination.Cells.Clear
shtDestination.Range("A1").Value = "Name"
shtDestination.Range("B1").Value = "Hours"
lastRowDest = 1 'start with row 1 as destination
For i = 1 To lastRowSrc 'loop through all used rows
If shtSource.Range("A" & i).Value <> vbNullString And _
shtSource.Range("B" & i).Value <> vbNullString Then 'check if cells are not a null string
shtSource.Range("A" & i & ":B" & i).Copy Destination:=shtDestination.Range("A" & lastRowDest + 1) 'copy current row
lastRowDest = lastRowDest + 1 'jump to the last used row in destination
End If
Next i
End Sub
This should accomplish what you're after.
Sub DoStuff()
Dim lastRow As integer, lastRowSheet2 As integer, i As Integer
Dim sheet1 As WorkSheet, sheet2 As Worksheet
Set sheet1 = Sheets("Sheet1")
Set sheet2 = Sheets("Sheet2")
lastRow = sheet1.Range("A" & Rows.Count).End(xlUp).Row
sheet2.Cells.Clear
For i = 1 To lastRow
If sheet1.Range("A" & i).Value <> "" And sheet1.Range("B" & i).Value <> "" then
lastRowSheet2 = sheet2.Range("A" & Rows.Count).End(xlUp).Row
sheet1.Range("A" & i & ":B" & i).Copy Destination:= sheet2.Range("A" & lastRowSheet2 + 1)
End If
Next i
End Sub