I have been using the code (code show below) suggested by PeterT in this public question
This macro works well if the data are in the first, second and third column like this of the sheet like this:
But now I have a more large spreadsheet and I would like to do the same but having one column and the other not immediately adjacent like this.
What modification do I need to do in the code to be able to do this.
Option Explicit
Sub testme()
FindValues "Profile"
End Sub
Sub FindValues(ByVal value As String)
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = ThisWorkbook
Set srcWS = srcWB.Sheets("Sheet1")
Dim dstWB As Workbook
Dim dstWS As Worksheet
Set dstWB = ThisWorkbook '--- change to the new workbook
Set dstWS = dstWB.Sheets("Sheet2")
'--- find the end of the data in the destination sheet
Dim dstRow As Long
With dstWS
dstRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
End With
With srcWS
Dim lastRow As Long
lastRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 1 To lastRow
If IsInMyList(.Cells(i, 1).value) Then
dstRow = dstRow + 1
dstWS.Cells(dstRow, 1).value = .Cells(i, 1).value
dstWS.Cells(dstRow, 2).value = .Cells(i, 2).value & "_" & .Cells(i, 3).value
End If
Next i
End With
End Sub
Function IsInMyList(ByVal value As String) As Boolean
Dim theList() As String
theList = Split("Albinism and nystagmus 31-gene panel,TAAD 27-gene panel (R125),PCD 29-gene panel", ",")
Dim item As Variant
For Each item In theList
If item = value Then
IsInMyList = True
Exit Function
End If
Next item
IsInMyList = False
End Function
I have tried by changing the selection of the column where I think the code does that but I dont get non a error neither the desired results
For i = 1 To lastRow
If IsInMyList(.Cells(i, 2).value) Then
dstRow = dstRow + 1
dstWS.Cells(dstRow, 2).value = .Cells(i, 2).value
dstWS.Cells(dstRow, 4).value = .Cells(i, 4).value & "_" & .Cells(i, 7).value
Non-Adjacent Columns
This is easily achieved by adding a string (srcColsList) containing the columns, writing the columns to an array (srcCols), and using the elements of the array as column 'identifiers', e.g. srcCols(0).
You are not using the parameter Profile passed to your sub, so I removed it.
Modify the A,F,D to fit your needs.
Option Explicit
Sub testme()
FindValues
End Sub
Sub FindValues()
Const srcColsList As String = "A,F,D" ' no spaces!
Dim srcCols() As String: srcCols = Split(srcColsList, ",")
Dim srcWB As Workbook: Set srcWB = ThisWorkbook
Dim srcWS As Worksheet: Set srcWS = srcWB.Sheets("Sheet1")
Dim dstWB As Workbook: Set dstWB = ThisWorkbook
Dim dstWS As Worksheet: Set dstWS = dstWB.Sheets("Sheet2")
'--- find the end of the data in the destination sheet
Dim dstRow As Long
With dstWS
dstRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
End With
With srcWS
Dim lastRow As Long
lastRow = .Cells(.Cells.Rows.Count, srcCols(0)).End(xlUp).Row
Dim i As Long
For i = 1 To lastRow
If IsInMyList(.Cells(i, srcCols(0)).Value) Then
dstRow = dstRow + 1
dstWS.Cells(dstRow, 1).Value = .Cells(i, srcCols(0)).Value
dstWS.Cells(dstRow, 2).Value = .Cells(i, srcCols(1)).Value _
& "_" & .Cells(i, srcCols(2)).Value
End If
Next i
End With
End Sub
Function IsInMyList(ByVal SearchString As String) As Boolean
Const StringList As String _
= "Albinism and nystagmus 31-gene panel," _
& "TAAD 27-gene panel (R125)," _
& "PCD 29-gene panel" ' no spaces!
IsInMyList = IsNumeric(Application _
.Match(SearchString, Split(StringList, ","), 0))
End Function
Related
Need some solution in VBA ->If the blank value in column A then takes value from column B.
I wrote some code, but I don't have any idea why this is not working.
dim LastR as Long
LastR = Worksheets("Sheet1").Range("BU" & Worksheets("Sheet1").Rows.Count).End(xlUp).Row
dim i as long
For i = LastR To 2 Step -1
If IsEmpty(Cells(i, "a")) Then Cells(i, "a").Value = Cells(i, "b").Value
Next i
You should check if the value is empty.
See two examples:
Dim LastR As Long
LastR = Worksheets("Sheet1").Range("BU" & Worksheets("Sheet1").Rows.Count).End(xlUp).Row
Dim i As Long
For i = LastR To 2 Step -1
'If Sheets("Sheet1").Cells(i, "a") = "" Then Sheets("Sheet1").Cells(i, 1).Value = Cells(i, 2).Value
If IsEmpty(Sheets("Sheet1").Cells(i, "a").Value) = True Then Sheets("Sheet1").Cells(i, 1).Value = Cells(i, 2).Value
Next i
Loop Through the Cells of a Column
All three versions do the same and are about equally efficient.
Option Explicit
Sub FillEmptiesConstants()
Const wsName As String = "Sheet1" ' Worksheet Name
Const fRow As Long = 2 ' First Row
Const lrCol As String = "BU" ' Last Row Column
Const lCol As String = "A" ' Lookup Column
Const dCol As String = "A" ' Destination Column
Const sCol As String = "B" ' Source Column
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
If lRow < fRow Then Exit Sub
Dim r As Long
For r = fRow To lRow
If IsEmpty(ws.Cells(r, lCol)) Then
ws.Cells(r, dCol).Value = ws.Cells(r, sCol).Value
End If
Next r
End Sub
Sub FillEmptiesSimple()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, "BU").End(xlUp).Row
If lRow < 2 Then Exit Sub
Dim r As Long
For r = 2 To lRow
If IsEmpty(ws.Cells(r, "A")) Then
ws.Cells(r, "A").Value = ws.Cells(r, "B").Value
End If
Next r
End Sub
Sub FillEmptiesSimpleWith()
With ThisWorkbook.Worksheets("Sheet1")
Dim lRow As Long: lRow = .Cells(.Rows.Count, "BU").End(xlUp).Row
If lRow < 2 Then Exit Sub
Dim r As Long
For r = 2 To lRow
If IsEmpty(.Cells(r, "A")) Then
.Cells(r, "A").Value = .Cells(r, "B").Value
End If
Next r
End With
End Sub
I want to compare two sheets,one sheet has the Parent and Project details for with rows for each month of 2019 and the other has Delivery manager .I want to copy the delivery managers name from the second in the first column -third and copy all the rows for this combination to third sheet from 1st one
I have tried copying the name of delivery manager to second one. It works
Sub CopyDM()
Dim LastRow1 As Integer, i As Integer, erow As Integer, LastRow2 As Integer, j As Integer, lastrow3 As Integer
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim Newwb As Workbook
Dim Newws As Worksheet
Dim wbDst As Workbook
Dim wsDst As Worksheet
Set wbDst = Workbooks("2019-07-11.xlsm")
Set wsDst = wbDst.Worksheets("2019-07-11")
Set Newwb = Workbooks("Copyrows.xlsm")
Set wbSrc = Workbooks("Project_ID_Master_List_report.xlsm")
Set wsSrc = wbSrc.Worksheets("Project_ID_Master_List_report")
Set Newws = Newwb.Worksheets("Sheet1")
LastRow1 = wsDst.Range("A" & wsDst.Rows.Count).End(xlUp).Row
LastRow2 = wsSrc.Range("A" & wsSrc.Rows.Count).End(xlUp).Row
For i = 2 To LastRow1
For j = 2 To LastRow2
If wsSrc.Cells(j, 2).Value = wsDst.Cells(i, 5).Value And _
wsSrc.Cells(j, 5).Value = wsDst.Cells(i, 2).Value Then
wsSrc.Cells(j, 3).Copy wsDst.Cells(i, 15)
End If
Next j
Next i
End Sub
Sub CopyDM()
Dim LastRow1 As Integer, i As Integer, LastRow2 As Integer, j As Integer, lastrow3 As Integer, LastCol As Integer, k As Integer
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim Newwb As Workbook
Dim Newws As Worksheet
Dim wbDst As Workbook
Dim wsDst As Worksheet
Set wbDst = Workbooks("2019-07-11.xlsm")
Set wsDst = wbDst.Worksheets("2019-07-11")
Set Newwb = Workbooks("Copyrows.xlsm")
Set wbSrc = Workbooks("Project_ID_Master_List_report.xlsm")
Set wsSrc = wbSrc.Worksheets("Project_ID_Master_List_report")
Set Newws = Newwb.Worksheets("Sheet1")
LastRow1 = wsDst.Range("A" & wsDst.Rows.Count).End(xlUp).Row
LastRow2 = wsSrc.Range("A" & wsSrc.Rows.Count).End(xlUp).Row
' lastrow3 = Newws.Range("A" & Newws.Rows.Count).End(xlUp).Row
LastCol = Sheets("wsDst").Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To LastRow1
For j = 2 To LastRow2
lastrow3 = Newws.Range("A" & Newws.Rows.Count).End(xlUp).Row
For k = 1 To LastCol
If wsSrc.Cells(j, 2).Value = wsDst.Cells(i, 5).Value And _
wsSrc.Cells(j, 5).Value = wsDst.Cells(i, 2).Value Then
Newws.Cells(lastrow3, 1).Copy wsDst.Cells(i, 15)
End If
Next k
Next j
Next i
End Sub
I'm attempting to match values between two sheets and if found and the conditions are met, perform the action of changing the cell colour.
PROBLEM:
I'm getting an error with my For...Next loop, even though I thought I have a NEXT for each FOR statement. Not sure what I've done wrong.
Also, I'm not sure my counters are setup correctly to accurately scan through each sheet/column needed. Any help would be appreciated.
Sub ReadData()
Dim wb As Workbook
Dim ws As Worksheet
Dim lastrow As Long
Dim i As Long
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Ref1")
Set ws2 = wb.Sheets("TRA")
lastrow = Sheets("Ref1").Cells(Rows.Count, "A").End(xlUp).Row
lastrow2 = Sheets("TRA").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Ref1").Activate
i = 2
k = 2
For i = 2 To lastrow
For k = 2 To lastrow2
If Cells(i, 4).Value = "Active" Then
If ws.Cells(i, 18).Value = ws2.Cells(i, 1).Value And (ws2.Cells(i, 23).Value <> "Cancelled" Or ws2.Cells(i, 23).Value <> "Completed") Then
Cells(i, 20).Interior.ColorIndex = 9
End If
Next
Next
End Sub
Quick Repair
To better understand the code, it is often preferable to use letters,
instead of numbers, for columns.
The Code
Sub ReadData()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastrow As Long
Dim lastrow2 As Long
Dim i As Long
Dim k As Long
' Use ThisWorkbook instead of ActiveWorkbook, if the code is
' in the same workbook where these sheets are.
With ActiveWorkbook
Set ws = .Worksheets("Ref1")
Set ws2 = .Worksheets("TRA")
End With
lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
lastrow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow
If ws.Cells(i, "D").Value = "Active" Then
For k = 2 To lastrow2
If ws.Cells(i, "R").Value = ws2.Cells(k, "A").Value _
And ws2.Cells(k, "W").Value <> "Cancelled" _
And ws2.Cells(k, "W").Value <> "Completed" Then
ws.Cells(i, "T").Interior.ColorIndex = 9 ' Brown
Exit For
End If
Next
End If
Next
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 have the following Macro:
Sub Remove_Junk_Data()
Call Open_Workbook
Call Scrub_Master
Call Scrub_Change_History
Call Scrub_Update
Call Scrub_ExistingOwnership
Call Save_Scrubbed
End Sub
Sub Open_Workbook()
Workbooks.Open "https://company.sharepoint.com/sites/project/subproject/subsubproject/subsubprojecttool/tooloutput/tooloutput.xlsx"
Workbooks("tooloutput.xlsx").Activate
End Sub
Sub Scrub_Master()
Dim myValue As String
Dim LastRow As Long
Dim i As Long
Dim r As Range
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
Sheets("Master").Select
For i = LastRow To 1 Step -1
Set r = Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End Sub
Sub Scrub_Change_History()
Dim myValue As String
Dim LastRow As Long
Dim i As Long
Dim r As Range
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
Sheets("Change History").Select
For i = LastRow To 1 Step -1
Set r = Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End Sub
Sub Scrub_Update()
Dim myValue As String
Dim LastRow As Long
Dim i As Long
Dim r As Range
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
Sheets("Update").Select
For i = LastRow To 1 Step -1
Set r = Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End Sub
Sub Scrub_ExistingOwnership()
Dim myValue As String
Dim LastRow As Long
Dim i As Long
Dim r As Range
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
Sheets("ExistingOwnership").Select
For i = LastRow To 1 Step -1
Set r = Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End Sub
Sub Save_Scrubbed()
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= _
"https://company.sharepoint.com/sites/project/subproject/subsubproject/subsubprojecttool/tooloutput/tooloutput.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.DisplayAlerts = False
Workbooks("Master_FM_Update.xlsx").Close
End Sub
If I comment out the "Open_Workbook" sub and manually open the workbook then run the remainder of Remove_Junk_Data(), it works perfectly.
If I try to run Remove_Junk_Data with Open_Workbook active, then no errors are thrown, but the 4 middle subs dont do anything...
Has anyone ran into anything like this? Did you find a resolution? I want to click a button and have all 6 subs do their thing correctly...
Edit: With input, new macro, and it works! Thanks guys!:
Sub Remove_Junk_Data()
Workbooks.Open "https://company.sharepoint.com/sites/project/subproject/subsubproject/Subsubprojecttool/tooloutput/tooloutput.xlsx"
Dim myValue As String
Dim LastRow As Long
Dim i As Long
Dim r As Range
With Workbooks("tooloutput.xlsx").Sheets("Master")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
For i = LastRow To 1 Step -1
Set r = .Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End With
With Workbooks("tooloutput.xlsx").Sheets("Change History")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
For i = LastRow To 1 Step -1
Set r = .Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End With
With Workbooks("tooloutput.xlsx").Sheets("Update")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
For i = LastRow To 1 Step -1
Set r = .Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End With
With Workbooks("tooloutput.xlsx").Sheets("ExistingOwnership")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
For i = LastRow To 1 Step -1
Set r = .Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End With
End Sub
I have done some changes to your code, the comments in the procedure intent to explain the changes. My advice is that besides what you are getting from sites like Stackoverflow you should also read the corresponding documentation to achieve a deeper understanding of the concepts and resources used. Nevertheless, do not hesitate to ask question as you go forward in developing your programing skills.
The code below consolidates all what you are trying to do in one procedure, there you'll see how to run repetitive code for a series of values (i.e. worksheets in this case)
Suggest to visit the following pages:
Variables & Constants, Application Object (Excel), Excel Objects
With Statement, For...Next Statement, For Each...Next Statement,
If...Then...Else Statement
Worksheets Object (Excel), Worksheet Object (Excel), Range Object (Excel)
Sub Remove_Junk_Data()
Rem Use an Array Variable to List all the worksheets you want to work with
Dim aWsh As Variant, vItm As Variant
aWsh = Array("Master", "Change History", "Update", "ExistingOwnership")
Rem Declare Object Variables
Dim Wbk As Workbook
Dim Wsh As Worksheet
Dim lRowLst As Long
Dim lRow As Long
Rem Open Workbook & Set Workbook Object Variable
Set Wbk = Workbooks.Open("https://company.sharepoint.com/sites/project/subproject/subsubproject/subsubprojecttool/tooloutput/tooloutput.xlsx")
Rem Loop throught the worksheet list and process each one
For Each vItm In aWsh
Rem Set Worksheet Object Variable
Set Wsh = Wbk.Worksheets(vItm)
With Wsh
lRowLst = Cells(Rows.Count, "A").End(xlUp).Row
For lRow = lRowLst To 1 Step -1
With .Cells(lRow, 1)
If .Value2 = Empty And Not (.HasFormula) Then .EntireRow.Delete
End With: Next: End With: Next
Application.DisplayAlerts = False
Wbk.Save
Application.DisplayAlerts = True
Workbooks("Master_FM_Update.xlsx").Close
End Sub