Based on the text ("SNV") present in column L of the "HiddenSheet" worksheet, I would like to select and copy cells in columns 1 to 6 for all rows for which the "SNV" text is present in column L.
Then I would like to paste the values of the copied cells in the SNVReports worksheet.
Sub Macro2()
a = Worksheets("HiddenSheet").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To a
If Worksheets("HiddenSheet").Cells(i, 12).Value = "SNV" Then
Worksheets("HiddenSheet").Range(Cells(i, 1), Cells(i, 6)).Copy
Worksheets("SNVReports").Activate
b = Worksheets("SNVReports").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("SNVReports").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("HiddenSheet").Activate
End If
Next
Application.CutCopyMode = False
End Sub
I sometimes receive:
"Application-defined or object-defined error"
and it is apparently related to my range:
Worksheets("HiddenSheet").Range(Cells(i, 1), Cells(i, 6)).Copy
Your Cells(i,#) references aren't qualified. So if the SNVReports tab is active when the macro runs, it's confused as to what range you're talking about.
The whole code could do with a tidy-up:
Sub Macro2a()
Dim sourcesheet As Worksheet
Dim destsheet As Worksheet
Dim lastsourcerow as Long
Dim lastdestrow as Long
Dim i as Long
Set sourcesheet = Worksheets("HiddenSheet")
Set destsheet = Worksheets("SNVReports")
With sourcesheet
lastsourcerow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To lastsourcerow
If .Cells(i, 12).Value = "SNV" Then
lastdestrow = destsheet.Cells(destsheet.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(i, 1), .Cells(i, 6)).Copy destsheet.Cells(lastdestrow + 1, 1)
End If
Next
End With
End Sub
Related
I am not very familiar with VBA and I need help with programming a code to do the following:
On Button Click in Sheet 1
Copy values from Column A if value =1 to worksheet 2 into column A.
If the value = 2 then copy it to worksheet 3 into column A.
This is my current code.
Sub Mandat1_Click()
For Each Cell In Range("A2:A81")
If Cell.Value = 1 Then
Sheets(3).Range("C2:C81").Value = Sheets(1).Range("A2:A81").Value
End If
Next Cell
End Sub
This is my best guess at what you are trying to do.
Sub moveData()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets(1)
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets(2)
Dim ws3 As Worksheet: Set ws3 = ThisWorkbook.Worksheets(3)
Dim r As Integer
For r = 2 To 81
If ws1.Cells(r, 1).Value = 1 Then
ws2.Cells(r, 1).Value = ws1.Cells(r, 1).Value
ElseIf ws1.Cells(r, 1).Value = 2 Then
ws3.Cells(r, 1).Value = ws1.Cells(r, 1).Value
End If
Next r
End Sub
Sub TransferData()
Dim lastrow As Long, erow As Long
'Check last filled row
lastrow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Sheets(1).Cells(i, 1).Value = 1 Then
'Copies data from from Sheet 1 column 1
Sheets(1).Cells(i, 1).Copy
erow = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
'Pastes data in Sheet 2 column 1
Sheets(1).Paste Destination:=Sheets(2).Cells(erow + 1, 1)
Sheets(1).Cells(i, 1).Copy
eerow = Sheets(6).Cells(Rows.Count, 1).End(xlUp).Row
Sheets(1).Paste Destination:=Sheets(6).Cells(eerow + 1, 1)
End If
Next i
End Sub
I'm writing a code to look for a specific keyword ("Team") and when found I want to paste the team name in a specific column ("D") for all rows above. If the keyword is not found I want to copy the entire row. This all pasted into a new sheet.
What I have:
x-------------x------------x
x-------------x------------x
Team A----x------------x
x-------------x-------------x
x-------------x-------------x
Team B----x-------------x
What I want:
x----x----x----A
x----x----x----A
x----x----x----B
x----x----x----B
Here's what I have so far:
Sub fun()
Dim j as Integer
Dim lastrow as Integer
Dim team as String
Dim sh As Worksheet
sh = Sheets("Sheet 1")
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlup).Row
Range("A" & lastrow).Select
for j = 1 to lastrow
If Instr(Cells(j,1).Value, "Team") Then
Cells(j,1).Value = Replace(Cells(j,1).Value, "Team ", "")
Cells(j,1).Value = team
Else
Range(Cells(j,1), Cells(j,3). Select
Selection.Copy
Windows("sheet.xlsm").Activate
ActiveSheet.Cells(1,1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=False
End If
next j
End Sub
I'm able to meet the second condition and paste entire rows but I'm unsure how to copy the team names and post them in column D in the new sheet.
Something like this:
Sub fun()
Dim j As Long, destRow As Long
Dim team As String, v, rngTeam As Range
Dim sh As Worksheet, shDest As Worksheet
Set sh = Sheets("Sheet1")
Set shDest = Sheets("Sheet2") 'for example
destRow = shDest.Cells(Rows.Count, 1).End(xlUp).Row + 1
For j = 1 To sh.Cells(Rows.Count, 1).End(xlUp).Row
v = sh.Cells(j, 1).Value
If InStr(v, "Team") > 0 Then
If Not rngTeam Is Nothing Then rngTeam.Value = Replace(v, "Team ", "") '<< set for already-copied rows
Set rngTeam = Nothing 'reset the range
Else
shDest.Cells(destRow, 1).Resize(1, 3).Value = sh.Cells(j, 1).Resize(1, 3).Value
'add to the range to populate next time we hit a "Team"
If rngTeam Is Nothing Then
Set rngTeam = shDest.Cells(destRow, 4)
Else
Set rngTeam = Application.Union(shDest.Cells(destRow, 4), rngTeam)
End If
destRow = destRow + 1
End If
Next j
End Sub
With the code I am currently using it will paste the information from Worksheet 1 to worksheet 2 in the Top line of worksheet2. What I want next is to use the same code but for different cell values and to copy the information from worksheet 1 to worksheet 2 but in the next available line in worksheet 2.
I have been researching about excel macros and vba for a while now and I am still having trouble. I have worked on not using select and activate within my excel code but I am still having trouble with my code now. I am trying to automate my excel workbook as much as I can for easier use.
Sub Copy()
Dim Cell As Range
Dim myRow As Long
myRow = 1
With Sheets("Sheet1")
For Each Cell In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
If Cell.Value = "Tuck Chow" And Cell.Offset(0, 1).Value = "OPT" Then
.Rows(Cell.Row).Copy Destination:=Sheets("Sheet2").Rows(myRow)
myRow = myRow + 1
End If
Next Cell
End With
End Sub
I would do something like this:
Sub Copy()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim newRow As Long
'setting sheets
Set sh1 = ThisWorkbook.Worksheets("Sheet1")
Set sh2 = ThisWorkbook.Worksheets("Sheet2")
With sh1
For Each cel In .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
If cel.Value = "Tuck Chow" And cel.Offset(0, 1).Value = "OPT" Then
'getting new row on Sheet2
If sh2.Cells(1, 1) = "" Then
newRow = 1
Else
newRow = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
'copying
cel.EntireRow.Copy Destination:=sh2.Cells(newRow, 1)
End If
Next cel
End With
'deselecting row
sh2.Cells(1, 1).Select
End Sub
Try:
Option Explicit
Sub test()
Dim LastRow1 As Long, LastRow2 As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow1
If .Range("A" & i).Value = "Tuck Chow" And .Range("B" & i).Value = "OPT" Then
LastRow2 = ThisWorkbook.Worksheets("Sheet2").Cells(ThisWorkbook.Worksheets("Sheet2").Rows.Count, "A").End(xlUp).Row
.Rows(i).Copy ThisWorkbook.Worksheets("Sheet2").Rows(LastRow2 + 1)
End If
Next i
End With
End Sub
I may have up to 8 unique values in column D. I am looking for a code that will copy & paste each row with unique value to a new sheet.
So I may have up to 8 new sheets.
Could you help me to build the code that will do that?
This is what I have so far:
Option Explicit
Sub AddInstructorSheets()
Dim LastRow As Long, r As Long, iName As String
Dim wb As Workbook, ws As Worksheet, ts As Worksheet, nws As Worksheet
Dim i As Integer
Dim m As Integer
'set objects
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Set ts = Sheets("Master")
'set last row of instructor names
LastRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row
'add instructor sheets
On Error GoTo err
Application.ScreenUpdating = False
For r = 17 To LastRow 'assumes there is a header
iName = ws.Cells(r, 4).Value
With wb 'add new sheet
ts.Copy After:=.Sheets(.Sheets.Count) 'add template
Set nws = .Sheets(.Sheets.Count)
nws.Name = iName
Worksheets(iName).Rows("17:22").Delete
Worksheets("Master").Activate
Range(Cells(r, 2), Cells(r, 16)).Select
Selection.Copy
m = Worksheets(iName).Range("A15").End(xlDown).Row
Worksheets(iName).Cells(m + 1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
Next r
err:
ws.Activate
Application.ScreenUpdating = True
End Sub
The thing is that this macro is creating new sheets, which is not necessary. I only want to make following.
If you find a unique value in column D (which will have exact name as other sheet), find this sheet and paste whole row in there.
Sub CopyFromColumnD()
Dim key As Variant
Dim obj As Object
Dim i As Integer, lng As Long, j As Long
Dim sht As Worksheet, mainsht As Worksheet
Set obj = CreateObject("System.Collections.ArrayList")
Set mainsht = ActiveSheet
With mainsht
lng = .Range("D" & .Rows.Count).End(xlUp).Row
With .Range("D1", .Range("D" & lng))
For Each key In .Value
If Not obj.Contains(key) Then obj.Add key
Next
End With
End With
For i = 0 To obj.Count - 1
Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
sht.Name = obj(i)
For j = 1 To lng
If mainsht.Cells(j, 4).Value = obj(i) Then
mainsht.Rows(j).EntireRow.Copy Destination:=Range("A1")
Exit For
End If
Next
Next
End Sub
Ok, I did the workaround. I have created a list of unique values in a separate sheet.
Sub copypaste()
Dim i As Integer
Dim j As Integer
LastRow = Worksheets("Master").Range("D17").End(xlDown).Row
For i = 17 To LastRow
For j = 2 To 10
Workstream = Worksheets("Database").Cells(j, 5).Value
Worksheets("Master").Activate
If Cells(i, 4) = Worksheets("Database").Cells(j, 5).Value Then
Range(Cells(i, 2), Cells(i, 16)).Select
Selection.Copy
Worksheets(Workstream).Cells(1, 1).PasteSpecial Paste:=xlPasteValues
Else
End If
Next j
Next i
End Sub
Thank you everyone for help and your time!
I am new with VBA coding, could you help me towards this concern?
I am currently creating a macro which will search the specific text in the column AJ (e.g. "Chase") and if found, it will lookup for the entity from the column A and then copy paste it to other sheet.
Many thanks in advance!
Try this. Taken from the comments. Remember that the errors you might get is because of the VLookup formula. You need to look at how the VLookup formula is working.
=VLOOKUP(Value you want to look up, range where you want to lookup the value, the column number in the range containing the return value, Exact Match or Approximate Match – indicated as 0/FALSE or 1/TRUE).
The formula is searching for "Check". The errors you get is in the range you are searching in, you are searching for "AE7:A2693" that is column AE to A - it is not possible to search backwards, so it should be A2693:AE7. You have to find the correct range and change it in the code below.
Are you sure that column 31 is containing the return value?
Sub EachLoopExample()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim MyCell As Range
Dim sResult As String
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet3")
For Each MyCell In ws1.Range("AE:AE")
If MyCell.Value = "check" Then
sResult = Application.WorksheetFunction.VLookup("check", ws1.Range("B1:C3"), 1, False)
ws2.Range("A2").Value = sResult
End If
Next MyCell
End Sub
Sub EachLoop()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim FinalRow As Integer
Dim i As Integer
Set ws1 = Sheet1
Set ws2 = Sheet3
ws1.Select
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 7 To FinalRow
If Cells(i, 31) = "check" Then
Range(Cells(i, 1), Cells(i, 7)).Copy
ws2.Select
Range("A200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
ws1.Select
End If
Next i
ws2.Select
Range("B2").Select
Call EachLoop2
End Sub
Sub EachLoop2()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim FinalRow As Integer
Dim i As Integer
Set ws1 = Sheet1
Set ws2 = Sheet3
ws1.Select
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 7 To FinalRow
If Cells(i, 32) = "check" Then
Range(Cells(i, 1), Cells(i, 13)).Copy
ws2.Select
Range("H200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
ws1.Select
End If
Next i
ws2.Select
Range("B2").Select
Call EachLoop2_ext
End Sub
Sub EachLoop2_ext()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim FinalRow As Integer
Dim i As Integer
Set ws1 = Sheet1
Set ws2 = Sheet3
ws2.Select
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To FinalRow
If Range(Cells(i, 9), Cells(i, 13)) = "" Then
ws2.Select
Range(Cells(i, 9), Cells(i, 13)).ClearContents
Range(Cells(i, 14), Cells(i, 20)).Cut
Range("I200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
Else
ws2.Select
Range(Cells(i, 9), Cells(i, 13)).ClearContents
Range(Cells(i, 14), Cells(i, 20)).Cut
Range("I200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next i
ws2.Select
Range("I2").Select
End Sub