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 !
Related
I am starting out with a table containing a name which corresponds to a job code and the start date of said job. See below:
The desired outcome of this is to almost flip it (it is becoming part of a bigger macro, must use VBA for this)
I need dates along the column headings, and the list of unique names. In the column will appear the job for that date. See below for an example:
I have been able to get the code to select all of the rows containing a persons name, however I can't workout how to one by one go through each of the selected rows, copy the job code and paste it to the new table under the correct corresponding date.
Since some jobs have multiple people this code uses InStr() to find occurances of the unqiue names
Sub NewTable()
Dim Rng As Range
Dim Cell As Object
Dim Found As Range
Dim Ws As Worksheet
Set Ws = Worksheets("Sheet1")
Set Rng = Ws.Range("D:D")
searchString = "Emily"
For Each Cell In Rng
If InStr(Cell, searchString) > 0 Then
If Not Found Is Nothing Then
Set Found = Union(myUnion, Cell.EntireRow)
Else
Set Found = Cell.EntireRow
End If
End If
Next
If Found Is Nothing Then
MsgBox "The text was not found in the selection"
Else
Found.Select
End If
End Sub
Any help would be appreciated
Try this out:
Sub Tester()
Dim rw As Range, wsData As Worksheet, wsPivot As Worksheet, arr, e, r, c
Set wsData = ThisWorkbook.Worksheets("Input") 'sheet with original data
Set wsPivot = ThisWorkbook.Worksheets("Pivot") 'sheet for the final table
'loop over each row in the input table
For Each rw In wsData.Range("B6:E" & wsData.Cells(Rows.Count, "B").End(xlUp).Row).Rows
If Application.CountA(rw) = 3 Then 'row has data?
'try to match the date: add as new date if no match
c = Application.Match(CLng(rw.Cells(3).Value), wsPivot.Rows(1), 0)
If IsError(c) Then
c = wsPivot.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If c < 4 Then c = 4 'dates start in D1
wsPivot.Cells(1, c).Value = rw.Cells(3).Value 'add the date
End If
arr = Split(rw.Cells(2).Value, ",") 'get array of all names
'check row for each name: add as new name if no match
For Each e In arr
'look for the name in Col B
r = Application.Match(Trim(e), wsPivot.Columns("B"), 0)
'if name not found, then add it in the next empty cell
If IsError(r) Then
r = wsPivot.Cells(Rows.Count, "B").End(xlUp).Row + 1
If r < 4 Then r = 4 'names begin in B4
wsPivot.Cells(r, "B").Value = e
End If
wsPivot.Cells(r, c).Value = rw.Cells(1).Value 'add the Job Code
Next e
End If
Next rw
End Sub
need help in Excel VBA, please. I am trying to find a string in a cell and if found want to copy the cell to a specific cell, want to loop for next rows until end of data rows. I used the code as follows it find and copy but copy to the next cell, I need in a specific cell. Thank you.
Sub TEST()
Dim c As Range
For Each c In Range("B1:K100")
If InStr(1, c.Text, "Address:") Then
c.Copy Destination:=c.Offset(ColumnOffset:=1)
End If
Next c
End Sub
This is my guess at what you are attempting to do
Sub Test()
Dim src As Worksheet: Set src = ThisWorkbook.Worksheets("Source")
Dim c As Integer, r As Integer
Dim lastRow As Integer: lastRow = src.Cells(src.Rows.Count, 1).End(xlUp).Row ' assumes your lowest piece of content will be in column 1
Dim lastCol As Integer: lastCol = src.Cells(1, src.Columns.Count).End(xlToLeft).Column ' assumes your rightmost piece of content will be located in row 1
Dim destinationCol As Integer: destinationCol = lastCol + 1
For r = 1 To lastRow
For c = 1 To lastCol
If InStr(1, src.Cells(r, c).Value, "Address:") Then
src.Range(src.Cells(r, c), src.Cells(r, c)).Copy Destination:=src.Range(src.Cells(r, destinationCol), src.Cells(r, destinationCol))
End If
Next c
Next r
End Sub
Col B on "Sheet2" contains 370 rows of data.
Starting with "Sheet2" Cell B1, I want to search for a matching value in Col B on "Sheet1" (it could be located anywhere in the first 300 rows of "Sheet1" Col B).
If a match is found, copy the entire row from "Sheet1" and paste to Row1 on "Sheet2". Then, move to "Sheet2" Cell B2 and repeat the search, this time pasting the entire row from "Sheet1" to Row2 on "Sheet2". Continue moving thru the entire column of data on "Sheet2", searching for each cell's value on "Sheet1". If a search doesn't return a match, then do not paste anything to that row on "Sheet2" and just proceed to search for the next cell on "Sheet2". (For example, if Sheet1 Col B doesn't contain a match for Sheet2 Cell B3, then nothing gets pasted in Sheet2 Row3.)
I have found the following example, which starts to help me, but it specifies the search value and doesn't loop thru the entire column of values like I am attempting to do.
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("Sheet1")
Set Target = ActiveWorkbook.Worksheets("Sheet2")
J = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("E1:E1000") ' Do 1000 rows
If c = "yes" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
This should do the trick, and do it fast:
Option Explicit
Sub CopyYes()
'You need Microsoft Scripting Runtime library under Tools-References for this
Dim arrPaste As Variant: arrPaste = Sheet2.UsedRange.Value
Dim arrCopy As Variant: arrCopy = Sheet1.UsedRange.Value
Dim MyMatches As New Dictionary: Set MyMatches = CreateDictionary(arrCopy)
Dim i As Long
For i = 1 To UBound(arrPaste)
If arrPaste(i, 2) = vbNullString Then Exit For
If MyMatches.Exists(arrPaste(i, 2)) Then PasteData arrPaste, arrCopy, i, MyMatches(arrPaste(i, 2))
Next i
Sheet2.UsedRange.Value = arrPaste
Erase arrCopy
Erase arrPaste
End Sub
Private Function CreateDictionary(arr As Variant) As Dictionary
Dim i As Long
Set CreateDictionary = New Dictionary
For i = 1 To 300
CreateDictionary.Add arr(i, 2), i
Next i
End Function
Private Sub PasteData(arrPaste As Variant, arrCopy As Variant, i As Long, MyMatch As Long)
Dim j As Long
For j = 1 To UBound(arrCopy, 2)
If arrCopy(MyMatch, j) = vbNullString Then Exit For
arrPaste(i, j) = arrCopy(MyMatch, j)
Next j
End Sub
Use Range.Find to search for your matching cell
Use a Union to create a collection of the rows that are found
Once your loop is finished, copy your range all at once if the Union is not empty
Sub Shelter_In_Place()
Dim Source As Worksheet: Set Source = ThisWorkbook.Sheets("Sheet1")
Dim Target As Worksheet: Set Target = ThisWorkbook.Sheets("Sheet2")
Dim Found As Range, lr As Long
Dim CopyMe As Range
lr = Target.Range("B" & Target.Rows.Count).End(xlUp).Row
For i = 1 To lr
Set Found = Source.Range("B:B").Find(Target.Range("B" & i), LookIn:=xlWhole)
If Not Found Is Nothing Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, Target.Range("B" & i))
Else
Set CopyMe = Target.Range("B" & i)
End If
End If
Set Fouund = Nothing
Next i
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy
Source.Range("A1").PasteSpecial xlPasteValues
End If
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.
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