If a cell in column E = "Y", then I want to copy that cell's entire row into Sheet 2, and do this for each worksheet in the workbook, except Sheet 2.
Here's the code I've tried.
Sub Macro1()
Dim lastrow As Long
Dim cpyrow As String
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet2" Then
For Each cell In Range("E:E")
If cell.Value = "Y" Then
lastrow = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1
cpyrow = cell.Row & ":" & cell.Row
ws.Range(cpyrow).Copy Destination:=Sheets("Sheet2").Range("A" & lastrow)
End If
Next cell
End If
Next ws
End Sub
Sometimes it will copy the correct row, but other times it will copy rows whose cell in column E doesn't equal "Y", or it will skip over rows that do. Also why does it give different results when I run it while I'm on different sheets? Shouldn't it run the same and go through every worksheet?
You missed a parent sheet reference on the loop:
For Each cell In Range("E:E")
Should be
For Each cell In ws.Range("E:E")
Other wise you are testing the active sheet but copying the correct sheet on that row.
replace:
For Each cell In Range("E:E")
with:
For Each cell In ws.Range("E:E")
(there may be other errors)
Related
Sub Start()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("1")
Set ws2 = Sheets("2")
Dim LastRow As Long, i As Long
LastRow = Cells(Rows.Count, "D").End(xlUp).row
For i = 1 To LastRow
ws1.Range("D" & i).copy
ws2.Range("A2").PasteSpecial Paste:=xlPasteFormats
Next i
If ws1.Range("A" & i) = vbNullString Then
Exit Sub
End If
End Sub
I'm trying to make it so this code pastes the interior fill from column D, Into Column A, unless there is already interior fill present.
Any input appreciated.
Edit: I'm trying to copy the format (interior fill) from Sheet 1 and Sheet 2's Column A's (until the last row) and paste it to Sheet Column A. I'm trying to copy over once cell at a time, and ignore if there is already fill present in sheet 3, because my I dont want the format from sheets 1 and 2 to overwrite eachtoher.
I have 2 sheets, 'Initial' & 'Report1'. I'm trying to copy specific rows from 'Inital' to 'Report1' when the cell in column 'H' is = "On going".
I have the function as a button in excel but cant workout how to copy and paste the line and move onto the next cell.
Also, Column D is formula and needs to be pasted special to copy over.
I have attached the current code I have tried but it errors. Any help would be greatly appreciated.
Sub GenRep1_Click()
Dim Inti As Worksheet
Dim rep1 As Worksheet
Set Inti = ThisWorkbook.Worksheets("Inital")
Set rep1 = ThisWorkbook.Worksheets("Report1")
Dim rngA As Range
Dim cell As Range
Set rngA = Sheets("Inti").Range("H5:H9999")
For Each cell In rngA
If cell.Value = "On going" Then
cell.EntireRow.Copy
Sheets("Inti").Range("").End(xlDown).Select
ActiveSheet.Paste
End If
Next cell
End Sub
I expect the all rows in column 'H' that = "On Going" to be copied to "Report1".
I think this does what you want. You might want to improve the range you're looping through in case you only have, e.g. 100 cells of data.
A quicker approach than looping would be AutoFilter.
Sub GenRep1_Click()
Dim Inti As Worksheet
Dim rep1 As Worksheet
Set Inti = ThisWorkbook.Worksheets("Inital") 'check name - typo?
Set rep1 = ThisWorkbook.Worksheets("Report1")
Dim rngA As Range
Dim cell As Range
Set rngA = Inti.Range("H5:H9999") 'already defined worksheet so just use variable
'Set rngA = Inti.Range("H5",inti.range("H" & rows.count).end(xlup)) 'would be more efficient
For Each cell In rngA
If cell.Value = "On going" Then
cell.EntireRow.Copy
repl.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlValues 'copy to the other sheet
End If
Next cell
End Sub
I have two questions
How to combine data using two of the cells from workbookA and copy to workbookB on the same cell?
How do I start using for loop to copy it until the last row/column?
I have no clue on how to combine the data and I do not know where to place the variable inside the code for it to loop until its last column.
Dim Tlastrow As Integer
Tlastrow = Cells(1, Columns.Count).End(xlToLeft).Column
For r = 1 To Tlastrow
Workbooks("InputB.xls").Worksheets("HC_MODULAR_BOARD_20180112").Range("F3:G3").Copy _
Workbooks("Output.xls").Worksheets("Sheet1").Range("I3")
Next
Try this:
Option Explicit
Sub Paste()
Dim wsInput As Worksheet, wsOutput As Worksheet, LastRow As Long, C As Range
Set wsInput = Workbooks("InputB.xls").Worksheets("HC_MODULAR_BOARD_20180112")
Set wsOutput = Workbooks("Output.xls").Worksheets("Sheet1")
With wsInput
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row 'Last Row with data
For Each C In .Range("F3:F" & LastRow) 'loop for every row with data
wsOutput.Cells(C.Row, "I").Value = C & " " & C.Offset(0, 1)
Next C
End With
End Sub
This code is assuming you want to paste every row from your input workbook to the output workbook on the same rows, but merging F and G columns. It's just pasting the values, not formulas or formats.
I am trying to copy certain cells if the word "FLAG" is a cell in that same row.
For example, I have data in excel like the following:
So if the word Flag is in any of the cells I want to copy the Description, Identifier and Final Maturity columns (Columns A-C) as well as the corresponding date column. So for the first row (AA) under Jan/Feb there is the word Flag. I would want to copy over columns A-E to another worksheet or table.
I would like to use a VBA but I am not sure how
The following code will do what you expect, each time it finds the word FLAG, the first 3 cells will be copied as well as the value for the given month will be copied to a new row, and if a second flag is found that will be copied to the next available row:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim wsResult As Worksheet: Set wsResult = Sheets("Sheet2")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
For i = 2 To LastRow 'loop through rows
For x = 15 To 23 'loop through columns
If ws.Cells(i, x) = "FLAG" Then 'if FLAG found in column
NextFreeRow = wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row + 1 'get the next empty row of your wsResult sheet
ws.Range("A" & i & ":C" & i).Copy 'copy first three cells in given row
wsResult.Range("A" & NextFreeRow).PasteSpecial xlPasteAll 'paste into your Result sheet
ws.Cells(i, x - 11).Copy 'copy the value for which there was a flag
wsResult.Cells(NextFreeRow, 4).PasteSpecial xlPasteAll 'paste in the fourth cell in the sheet wsResult
End If
Next x
Next i
End Sub
Goal: Have the column header of any text in red be represented in column F of the same row as the text.
Problem: Code currently references active row, and for some reason copies F2 (which is written in red). I know the code currently would be attempting to copy/paste over a cell a few times, and I'll work that out later.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, ActiveCell.Column).Copy
Range("F" & (ActiveCell.row)).Select
ActiveSheet.Paste
End If
Next cell
Next row
End Sub
Not sure if I follow your logic. Your problem is that you reference active cell but you are not defining it or changing it other than through the pasting. I think you mean to reference cell (?)
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, cell.Column).Copy Range("F" & cell.row)
End If
Next cell
Next row
End Sub
You are never changing the active cell, so the copy command is always called on row 2 of the active cell, which much be in the F column. I changed the code below to fix the issue.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet ' this should be improved to point at the correct worksheet by name
Set rng = ws.Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
cell.Copy
ws.Range("F" & (cell.row)).PasteSpecial
End If
Next cell
Next row
End Sub