I'm trying to create a for loop that looks the first row in my data source (row 3) and then it pastes that in a new reference sheet, but then I want the loop to paste the same data again just below it. So row's 3 and 4 in the reference sheet will be identical. Then I want it to look at row 4 in my data source and do the same thing, i.e. paste the data into row's 5 and 6 in the reference sheet.
This is my code so far - right now it only pastes row 3 once because my range is fixed. How do I fix this to make it paste one more time and then look at the next row in the data source?
RowCount = Dump.Cells(Rows.count, 1).End(xlUp).row
RefRow = ref.Cells(Rows.count, 1).End(xlUp).row
With ThisWorkbook
With Dump
For i = 1 To RowCount
.Range("A3:AO3").Copy Destination:=ref.Range("A3")
.Range("A3:AO3").Copy Destination:=ref.Range("A" & RefRow)
RefRow = RefRow + 1
row = row + 1
Next i
End With
End With
Try this:
Sub CopyPasteDuplicateRows()
Dim i, z As Integer
Dim rg, rg2 As Range
Dim ws, ws2 As Worksheet
Set ws = Sheets("NameOfTheSourceSheet")
Set ws2 = Sheets("NameOfTheDestinySheet")
For i = 3 To ws.Range("A" & Rows.Count).End(xlUp).Row
Set rg = ws.Range("A" & i & ":AO" & i)
If i = 3 Then
Set rg2 = ws2.Range("A3:A4")
Else
z = ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
Set rg2 = ws2.Range("A" & z & ":A" & z + 1)
End If
rg.Copy
rg2.PasteSpecial xlPasteAll
Next
End Sub
Related
I am new to macro I have created a macro that copies data from excel sheet1 column A & B and paste it in sheet 2 with status as updates in column c. However, it is not working properly it executes with incorrect/incomplete way like for some values in sheet 2 column B it shows updated in column c but for some, it does not... Please help me below is my code.
Secondly, I have coded first for copy paste data from sheet1 to sheet2 there I have specified the range A2:A9999 and B2:B9999 I am not able to simplify it. I mean it should take the entire column A and B than the specified range. Please help me with these 2 parts.............
Sub CopyData()
Dim i As Long
Dim wt As Excel.Worksheet
Set wr = Worksheets("Sheet2")
'Copies and cuts the data from sheet1(TIS) and paste the same in sheet2
With Worksheets("SampleFile")
.Range("A2:A9999").Copy wr.Range("A2") 'Copy
.Range("A2:A9999").Cut wr.Range("A2") 'Cut
.Range("B2:B9999").Copy wr.Range("B2") 'Copy
.Range("B2:B9999").Cut wr.Range("B2") 'Cut
End With
For i = 1 To wr.Cells(wr.Rows.Count, "B").End(xlUp).Row
If wr.Range("B" & i).Value = "FXV" Then
wr.Range("C" & i).Value = "Updated"
ElseIf wr.Range("B" & i).Value = "FST" Then
wr.Range("C" & i).Value = "Updated"
ElseIf wr.Range("B" & i).Value = "FLB" Then
wr.Range("C" & i).Value = "Updated"
ElseIf wr.Range("B" & i).Value = "FFH" Then
wr.Range("C" & i).Value = "Updated"
ElseIf wr.Range("B" & i).Value = "FFJ" Then
wr.Range("C" & i).Value = "Updated"
End If
Next i
End Sub
This code should cut data from A2 to B and LastRow in worksheet SampleFile and paste it to Range A2 in worksheet Sheet2. Then it will loop through all the rows in Sheet2 looking for the value in column B, if it matches the Select Cases will input Updated in column C:
Option Explicit
Sub CopyData()
Dim wr As Worksheet: Set wr = Worksheets("Sheet2")
'Copies and cuts the data from sheet1(TIS) and paste the same in sheet2
'there is no need to copy if you are going to cut
'also use a defined range to copy instead 9999 rows
With ThisWorkbook.Worksheets("SampleFile")
Dim LastRow As Long: LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'you can also cut both columns at once
.Range("A2:B" & LastRow).Cut wr.Range("A2") 'Cut
End With
Dim i As Long
With wr
For i = 1 To .Cells(.Rows.Count, "B").End(xlUp).Row
'in this case is way shorter to code using the Select statement
'you could also use If x = y or x = z or x = a but Select looks cleaner.
.Cells(i, "B") = Trim(.Cells(i, "B"))
Select Case .Range("B" & i)
Case "FXV", "FST", "FLB", "FFH", "FFJ"
.Range("C" & i) = "Updated"
End Select
Next i
End With
End Sub
I have excel with 5 different sheets.
sheet3 and sheet4 i want delete rows based on the single column cell value.
in sheet 3 i want to delete rows based on H column cell values if H2="#N/A" and H503="#N/A" then delete entire rows.
in sheet 4 i want to delete rows based on b column cell values if B2="320857876",B3="32085678",B4="12133435" the delete the entire rows where B column cell values starts with 302.
and i want to delete all Data from 'C' column
My excel sheet is like this
Using excel file
Sub Create()
Dim LastRow As Long
Dim i As Long
LastRow = Range("B10000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("B" & i) = "#N/A" Then
Range("B" & i).EntireRow.Delete
End If
Next
End Sub
You've got a few requirements there and your code is fairly light but regarding the #N/A part of it, you can't just test for that text using the value approach, which is the default property returned for a range object.
Sub Create()
Dim LastRow As Long, i As Long
LastRow = Range("B10000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("B" & i).Text = "#N/A" Then
Range("B" & i).EntireRow.Delete
End If
Next
End Sub
... you need to use .Text to get that to work, or, If IsError(Range("B" & i)) Then is another approach.
The rest of your requirements is just logic. The rest of your code is relatively sound so you just need to work through it.
I hope that helps.
Sub delete_rows()
Dim sheet As Worksheet, cell As Range
Count = 1
For Each sheet In ThisWorkbook.Worksheets
If Count = 3 Then
lastrow = sheet.Cells(sheet.Rows.Count, "H").End(xlUp).Row
Set Rng = sheet.Range("H1:H" & lastrow)
For i = Rng.Cells.Count To 1 Step -1
If Application.WorksheetFunction.IsNA(Rng(i).Value) Then
Rng(i).EntireRow.Delete
ElseIf Rng(i).Value = "#NA" Then
Rng(i).EntireRow.Delete
End If
Next
ElseIf Count = 4 Then
lastrow = sheet.Cells(sheet.Rows.Count, "B").End(xlUp).Row
Set Rng = sheet.Range("B1:B" & lastrow)
Debug.Print (Rng(4).Text)
If Rng(2).Value = "320857876" And Rng(3).Value = "32085678" And Rng(4).Value = "12133435" Then
For i = Rng.Cells.Count To 1 Step -1
If Left(Rng(i).Value, 3) = "302" Then
Rng(i).EntireRow.Delete
End If
Next
End If
lastrow = sheet.Cells(sheet.Rows.Count, "C").End(xlUp).Row
Set Rng = sheet.Range("C1:C" & lastrow)
For Each cell In Rng
cell.Value = ""
Next cell
End If
Count = Count + 1
Next
End Sub
I'm trying to highlight the entire row grey if the value in column A begins with "ABC" as well as delete everything right of that cell. Any ideas on how to do this?
Dim DataRange As Range
Set DataRange = Range("A1:U" & LastRow)
Set MyRange = Range("A2:A" & LastRow)
For Each Cell In MyRange
If UCase(Left(Cell.Value, 3)) = "ABC" Then
Cell.EntireRow.Interior.ColorIndex = 15
Else
End If
Next
Here is pretty straightforward approach:
Dim lastRow As Long
Dim row As Long
Dim temp As String
' insert your sheet name here
With ThisWorkbook.Worksheets("your sheet name")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' you can change the starting row, right now its 1
For row = 1 To lastRow
' store whats in col A in a temporary variable
temp = Trim(CStr(.Range("A" & row).Value))
' if col A isn't 'ABC' clear & grey entire row
If UCase(Left(.Range("A" & row).Value), 3) <> "ABC" Then
.Rows(row).ClearContents
.Rows(row).Interior.ColorIndex = 15
' place temp variable value back in col A and make interior No Fill
.Range("A" & row).Value = temp
.Range("A" & row).Interior.ColorIndex = 0
End If
Next
End With
Here is another example; you stated "clear everything to the right" so I added offset to clear the contents of the cells not in column A.
Dim x As Long
For x = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If UCase(Left(Cells(x, 1).Value, 3)) = "ABC" Then
Range(Cells(x, 1), Cells(x, Columns.Count).End(xlToLeft)).Interior.ColorIndex = 15
Range(Cells(x, 1).Offset(, 1), Cells(x, Columns.Count).End(xlToLeft)).ClearContents
End If
Next x
I have two worksheets in one Excel workbook, and I only want to take the lines that have data in the cell (from worksheet1 into worksheet2) if Column A has data in it. My formula in worksheet 2 is =IF('Raw Data'!A2<>"", 'Raw Data'!A2,), but I actually don't want it to bring in the row at all if there is no data as shown in Rows 3 and 5. Right now it is bringing the whole row in:
In
you see that it is still bringing the row into worksheet 2 if there is no data. Any ideas how to only bring in the rows with the data?
Sub DataInCell()
Dim rw As Long
rw = 2
' Select initial sheet to copy from
Sheets("Raw Data").Select
' Find the last row of data - xlUp will check from the bottom of the spreadsheet up.
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' For loop through each row
For x = 2 To FinalRow
If Cells(x, 1).Value <> 0 Then
Range("A" & x & ":C" & x).Copy
Sheets("Sheet1").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 'Continue incrementing through the rows.
Cells(NextRow, 1).Select ' Find the next row.
ActiveSheet.Cells(NextRow, "A").PasteSpecial xlPasteAll ' Paste information.
Sheets("Raw Data").Select 'Reselect sheet to copy from. Probably uneccessary.
End If
Next x
End Sub
After you update the sheet names on the 3rd and 4th line, you will see that the code carries over the entire row. You can modify using Range(Cells, Cells) if you want partial ranges.
Option Explicit
Sub Non_Blanks()
Dim ms As Worksheet: Set ms = ThisWorkbook.Sheets("Sheet1") '<-- Master Sheet
Dim ns As Worksheet: Set ns = ThisWorkbook.Sheets("Sheet2") '<-- New Sheet
Dim i As Long, MoveMe As Range, LR As Long
For i = 2 To ms.Range("B" & ms.Rows.Count).End(xlUp).Row
If ms.Range("A" & i) = "*" Then
If Not MoveMe Is Nothing Then
Set MoveMe = Union(MoveMe, ms.Range("A" & i))
Else
Set MoveMe = ms.Range("A" & i)
End If
End If
Next i
If Not MoveMe Is Nothing Then
LR = ns.Range("A" & ns.Rows.Count).End(xlUp).Offset(1).Row
MoveMe.EntireRow.Copy
ns.Range("A" & LR).PasteSpecial xlPasteValuesAndNumberFormats
End If
End Sub
I have a text string that is using the ^ symbol as a delimiter.
I need to separate the text into new rows rather than new columns.
I need to create new rows to not overwrite the next line of data below it.
Is this possible without using a macro? I'm not against using one, I just wouldn't know where to start to write it.
Below is a pic of some sample data. The top part is how it's listed, and the bottom (in yellow) is how I would like it.
Using Excel 2010 on Windows 7 Pro.
Thanks to those that responded. A friend was able to help by providing the following code:
Sub Breakout()
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 1).End(xlUp).Row
For r = LR To 2 Step -1
Set MyCell = Cells(r, 1)
Arry = Split(MyCell.Value, "^")
For c = 0 To UBound(Arry)
If c > 0 Then MyCell.Offset(c, 0).EntireRow.Insert
MyCell.Offset(c, 0) = Arry(c)
Next c
Next r
End Sub
Could try something like this:
Sub reArrange()
Dim inFirstRng As Range
Dim inRng As Range
Dim inCur As Variant
Dim outFirstRng As Range
Dim outCurRng As Range
Dim ws As Worksheet
'CHANGE ARGUMENT TO YOUR SHEET NAME
Set ws = Worksheets("Sheet2")
With ws
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA INPUT IS IN COLUMN A
Set inFirstRng = .Range("A3")
Set inRng = .Range(inFirstRng, inFirstRng.End(xlDown))
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA OUTPUT IS IN COLUMN A
Set outFirstRng = .Range("A9")
Set outCurRng = outFirstRng
End With
For Each cell In inRng.Cells
inCur = WorksheetFunction.Transpose(Split(cell.Value, "^"))
outCurRng.Resize(UBound(inCur), 1).Value = inCur
With ws
.Range("G" & outCurRng.Row & ":L" & outCurRng.Row).Value = _
.Range("G" & cell.Row & ":L" & cell.Row).Value
End With
Set outCurRng = outCurRng.Offset(UBound(inCur), 0)
Next cell
ws.Range("F" & outFirstRng.Row & ":F" & outCurRng.Row - 1).Value = 1
End Sub