I'm using this macro to copy from one sheet to another based on text in one cell, but it overwrites the data every time I run the macro. Is there any way to change the macro so that any data it pastes is in the next blank row?
Thanks :)
Sub CopyYes()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Main Data")
Set Target = ActiveWorkbook.Worksheets("Cheque Data")
j = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("A1:A1000") ' Do 1000 rows
If c = "Cheque" Then
Source.Rows(c.Row).Copy Target.Rows(j).End(xlUp).Offset(1)
j = j + 1
End If
Next c
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Main Data")
Set Target = ActiveWorkbook.Worksheets("Gift Card Data")
j = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("A1:A1000") ' Do 1000 rows
If c = "Gift Card" Then
Source.Rows(c.Row).Copy Target.Rows(j).End(xlUp).Offset(1)
j = j + 1
End If
Next c
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Main Data")
Set Target = ActiveWorkbook.Worksheets("Promo Code Data")
j = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("A1:A1000") ' Do 1000 rows
If c = "Promo Code" Then
Source.Rows(c.Row).Copy Target.Rows(j).End(xlUp).Offset(1)
j = j + 1
End If
Next c
Sheets("Main Data").Range("A2:F200").ClearContents
Sheets("Main Data").Range("J2:Q200").ClearContents
End Sub
Before each j=1 add
lastrow = Target.Range("A65000").End(xlUp).Row + 1
And change j = 1 to j = lastrow
Related
I need code which should first count how many times loop should be executed (suppose I have 18000 rows then 18000/7000 = 2.57 so 3 times), and then it should start a loop and copy first 7000 rows and paste in sheet2, and then the next 7000 rows (7001 to 14000) and this should continue until the range is empty.
I am referring to this code shown here, but it is not helping me out:
Dim r As Long
Dim c As Long
c = GetTargetColumn() ' Or you could just set this manually, like: c = 1
With Sheet1 ' <-- You should always qualify a range with a sheet!
For r = 1 To 7000 ' Or 1 To (Ubound(MyListOfStuff) + 1)
' Here we're looping over all the cells in rows 1 to 10, in Column "c"
.Cells(r, c).Value = MyListOfStuff(r)
'---- or ----
'...to easily copy from one place to another (even with an offset of rows and columns)
.Cells(r, c).Value = Sheet2.Cells(r + 3, 17).Value
Next r
End With
"This should continue until the range is empty." My code below copies the entire range but doesn't delete the original as your descriptions seems to imply. That should be quite easy, however, if required - just WsS.Cells.ClearContentsadded at the end.
Meanwhile, the code does what you describe. The number of rows to be copied in one loop can be set at the top of the procedure. I set Const BlockRowCount As Long = 3, doing 3 rows in a loop. It will also work for 7000 rows.
I noticed that your code doesn't seem to copy A1 to A1. Const FirstTargetCell As String = "B3" defines the top-left cell in the destination sheet as B3. You can specify any cell you want in that location and the code will hang the data from that peg.
Sub TransferData()
Const BlockRowCount As Long = 3
' cell A1 from the source sheet will arrive at
' FirstTargetCell on the target sheet. All other data relative to it.
Const FirstTargetCell As String = "B3" ' modify as required
Dim WsS As Worksheet ' Source sheet
Dim WsT As Worksheet ' Target sheet
Dim Src As Range ' source data range
Dim Tgt As Range ' target data range
Dim Arr As Variant ' data array
Dim Rl As Long, Cl As Long ' last used row / column
Dim Ct As Long ' first Target column
Dim Rs As Long, Rt As Long ' source / target row
Dim R As Long
Set WsS = Worksheets("Source Data")
Set WsT = Worksheets("Destination")
With Range(FirstTargetCell)
Rt = .Row
Ct = .Column
End With
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With WsS
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Cl = .Cells(1, .Columns.Count).End(xlToLeft).Column
For Rs = 0 To Abs(Int(Rl / BlockRowCount * -1)) - 1
R = Application.Min((Rs + 1) * BlockRowCount, Rl)
Set Src = .Range(.Cells(Rs * BlockRowCount + 1, 1), _
.Cells(R, Cl))
Arr = Src.Value
With WsT
Set Tgt = .Cells(Rt, Ct).Resize(UBound(Arr), UBound(Arr, 2))
Tgt.Value = Arr
End With
Rt = Rt + BlockRowCount
Next Rs
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
I'm very new to VBA. Trying to copy specific columns within a row if Column O has the text "Open".
Have tried the code below and it works except it copies the entire row and I only want to copy the row but limited to columns E to Q. How do i insert the column range requirement?
Sub Button2_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("SheetA")
Set Target = ActiveWorkbook.Worksheets("SheetB")
j = 3 ' Start copying to row 3 in target sheet
For Each c In Source.Range("O13:O1500") ' Do 1500 rows
If c = "Open" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
try
Source.Rows(c.Row).Columns("E:Q").Copy Target.Rows(j)
You should be able to use Union to gather the qualifying ranges and paste in one go which will be more efficient
Public Sub Button2_Click()
Dim c As Range, unionRng As Range
Dim Source As Worksheet, Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("SheetA")
Set Target = ActiveWorkbook.Worksheets("SheetB")
For Each c In Source.Range("O13:O1500")
If c = "Open" Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, Source.Rows(c.Row).Columns("E:Q"))
Else
Set unionRng = Source.Rows(c.Row).Columns("E:Q")
End If
End If
Next c
If Not unionRng Is Nothing Then unionRng.Copy Target.Range("A3")
End Sub
Intersect(Source.Rows(c.Row), Source.Range("E:Q")).Copy Target.Rows(j)
or
Source.Range("E:Q").Rows(c.Row).Copy Target.Rows(j)
While copying, you are trying to copy a specific range. So instead of using :
Source.Rows(c.Row).Copy Target.Rows(j)
Use
Source.Range("E*row*:Q*row*").Copy Target.Rows(j)
Where *row* is the row number. So you can copy Range from columns E to Q while keeping the row number fixed.
So the final code is
Sub Button2_Click()
Dim c As Range
Dim r As String 'Store the range here
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("SheetA")
Set Target = ActiveWorkbook.Worksheets("SheetB")
j = 3 ' Start copying to row 3 in target sheet
For Each c In Source.Range("O10:O15") ' Do 1500 rows
If c = "Open" Then
r = "E" & c.Row & ":" & "Q" & c.Row 'Creating the range
Source.Range(r).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
Hope this helps !
How do you reference a cell every four rows from a source sheet and then have it placed in the output sheet? Each cell has different values. Thank you in advance
This should do the job. Make sure that you make the required customisations before you try it in your workbook.
Sub TransferData()
Dim WsS As Worksheet, WsT As Worksheet ' Source & Target
Dim Rl As Long ' Last row
Dim Rs As Long, Cs As Long ' Source: Row, Column
Dim Rt As Long, Ct As Long ' Target: Row, Column
Set WsS = Worksheets("Source") ' change name as required
Set WsT = Worksheets("Source") ' I used the same sheet for my test
With WsT
Ct = 4 ' specify the column to write to (here column D)
Rt = .Cells(.Rows.Count, Ct).End(xlUp).Row + 1
End With
Application.ScreenUpdating = False
With WsS
Cs = 1 ' specify the column to read from (here column A)
Rl = .Cells(.Rows.Count, Cs).End(xlUp).Row
For Rs = 2 To Rl Step 4 ' start from row 2
WsT.Cells(Rt, Ct).Value = .Cells(Rs, Cs).Value
Rt = Rt + 1
Next Rs
End With
Application.ScreenUpdating = True
End Sub
Everything in this code works well until the piece where I need to delete the rows in column "I" of the source tab ("Status Report"). I have to run this macro several times to clear out all of the rows I want to delete because it appears to only delete one row at a time.
How can I get this macro to delete all of the rows I want and only run this code once?
Sub CopyYes()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Status Report")
Set Target = ActiveWorkbook.Worksheets("Sheet1")
j = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("I1:I1000") ' Do 1000 rows
If c = 1 Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
Source.Rows(c.Row).EntireRow.Delete
End If
Next c
End Sub
Thanks for your help!
How is this? It, as suggested by #yass, starts at the last row and works backwards.
Sub CopyYes()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Dim lastRow As Long
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Status Report")
Set Target = ActiveWorkbook.Worksheets("Sheet1")
blankRow = Target.Cells(Target.Rows.Count, 1).End(xlUp).Row ' Start copying to row 1 in target sheet
lastRow = 1000
' lastRow = Source.Cells(Source.Rows.Count, 9).End(xlUp).Row ' Uncomment this line if you want to do ALL rows in column I
With Source
For i = lastRow To 1 Step -1
If .Cells(i, 9).Value = 1 Then
If blankRow = 1 Then
.Rows(i).Copy Target.Rows(blankRow)
Else
.Rows(i).Copy Target.Rows(blankRow + 1)
End If
blankRow = Target.Cells(Target.Rows.Count, 1).End(xlUp).Row
.Rows(i).EntireRow.Delete
Next i
End With
End Sub
Note: The main difference is the For loop. AFAIK you can't do a For each x in Range loop backwards.
Having issues with some vba, if anyone can point me in the right direction it would be greatly appreciated, currently my code is returning a full row of data and it is returning multiple rows, this is my current code.
Sub BUTTONtest_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Two Years")
Set Target = ActiveWorkbook.Worksheets("Two Years League")
j = 3 ' Start copying to row 1 in target sheet
For Each c In Source.Range("G6:K6") ' Do 50 rows
If c.Text = "OVER" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
I need to look at each row and in each row if the word "OVER" appears I need it to return the information in the side bar e.g. column B I would need this to apply for each wee section e.g. Column C- F should return the number from column B and H-K should return G etc.
This?
Sub BUTTONtest_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Two Years")
Set Target = ActiveWorkbook.Worksheets("Two Years League")
j = 3 ' Start copying to row 1 in target sheet
For i = 1 To 3 'Number of ¿wees?
For Each c In Source.Range(Cells(6, 5 * i - 2), Cells(50, 5 * i + 1)) ' Do 50 rows
If c.Text = "OVER" Then
Target.Cells(j, 1) = Source.Cells(c.Row, 5 * i - 3)
j = j + 1
End If
Next c
Next i
End Sub
EDIT
If don't want repeated rows, try this one:
Sub BUTTONtest_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Two Years")
Set Target = ActiveWorkbook.Worksheets("Two Years League")
j = 3 ' Start copying to row 1 in target sheet
a = 1
For i = 1 To 3 'Number of ¿wees?
For Each c In Source.Range(Cells(6, 5 * i - 2), Cells(50, 5 * i + 1)) ' Do 50 rows
If c.Text = "OVER" Then
If a <> c.Row Then
Target.Cells(j, 1) = Source.Cells(c.Row, 5 * i - 3)
j = j + 1
a = c.Row
End If
End If
Next c
Next i
End Sub
you could try this code (commented)
Option Explicit
Sub BUTTONtest_Click()
Dim Source As Worksheet
Dim Target As Worksheet
Dim iSection As Long
Dim sectionIniCol As Long, sectionEndCol As Long
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Two Years")
Set Target = ActiveWorkbook.Worksheets("Two Years League")
With Source '<--| reference 'Source' sheet
With .Range("B6:F" & .Cells(.Rows.Count, "B").End(xlUp).row) '<--| reference its columns "B:F" range from row 6 down to last non empty cell in column "B"
With .Offset(, -1).Resize(, 1) '<--| reference corresponding cells in column "A" (which is an empty column)
For iSection = 1 To 3 '<-- loop over all your three 5-columns sections
sectionIniCol = (iSection - 1) * 5 + 2 '<-- evaluate current section initial col
sectionEndCol = sectionIniCol + 4 '<-- evaluate current section ending col
.FormulaR1C1 = "=if(countif(RC" & sectionIniCol + 1 & ":RC" & sectionEndCol & ",""OVER"")>0,1,"""")" '<-- write (temporary) formulas in column "A" cells to result "1" should at least one "OVER" occurrence be in corresponding cells of current section columns
If WorksheetFunction.Sum(.Cells) > 1 Then Intersect(.Columns(sectionIniCol), .SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow).Copy Target.Cells(Target.Rows.Count, 1).End(xlUp).Offset(1) '<-- if any occurrence of "OVER" has been found then copy section initial column cells corresponding to column "A" cells marked with "1" and paste them in from first empty row of 'Target' sheet...
Next iSection
.ClearContents '<--| delete (temporary) formulas in target column "A"
End With
End With
End With
End Sub