I realize there are a few different similar ideas on here. But I need help with this simple compare function.
My goal is to compare two different cells and if they are the same, replace it with its full non-abbreviated name.
Thank you for your time!!!
I.E
Sheet1 Sheet2
Column H Column A Column B
Dept Dept Department
This is what I have (Yes simple), but the cell H is not updating to the non-abbreviation:
Sub updateDeptNames()
'Format user ID from the email column
Dim ws As Worksheet, ws2 As Worksheet
Dim LastRow As Long, i As Long
Dim tmpArray() As String, tempDept As String
Set ws = ActiveWorkbook.Sheets("Student_Travel_DB") '--> This is the relevant sheet
Set ws2 = ActiveWorkbook.Sheets("gokoutd") '--> This is the relevant sheet
LastRow = 1000 ''Bug finding the last row, had to hard code it
For i = 2 To LastRow 'Iterate through all the rows in the sheet
For j = 2 To 112
tempDept = ws2.Range("A" & j).Value
If ws.Range("H" & i).Value = tempDept Then
ws.Range("H" & i) = ws2.Range("B" & j).Value
End If
Next j
Next i
End Sub
You can more easily use VLOOKUP either on your worksheet or with VBA:
Sub GetFullName()
Dim cl As Range, data As Range, lookUpRng As Range
Set data = Worksheets("Student_Travel_DB").Range("A1:A10")
Set lookUpRng = Worksheets("gokoutd").Range("A1:B10")
On Error Resume Next
For Each cl In data
cl = WorksheetFunction.VLookup(cl, lookUpRng, 2, False)
Next cl
End Sub
You'll need to change your range references.
Related
I am trying to write a vlookup code that uses the lookups tab as the array (A:B) and the revenue tab where the vlookup is in cell Y2. I need it to fill all the way through column Y.
Sub VLOOKUP()
Dim LookupsLastRow As Long
Dim RevenueLastRow As Long
Dim LookupsSheet As Worksheet
Dim RevenueSheet As Worksheet
'What are the names of our worksheets?
Set LookupsSheet = Worksheets("Lookups")
Set RevenueSheet = Worksheets("Revenue")
'Determine last row of source
With LookupsSheet
LookupsLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With RevenueSheet
'Determine last row in col P
RevenueLastRow = .Cells(.Rows.Count, "X").End(xlUp).Row
'Apply our formula
.Range("Y2:Y" & RevenueLastRow).Formula = _
"=VLOOKUP(V2,"Lookups"!$A$2:$B$" & LookupsLastRow & ",2,0)"
End With
End Sub
I want to paste the formula into a column by searching the column using its name.
My column name is Date1.
I want to find Date1 in my sheet and paste the following formula:
IF(ISBLANK(B5),"""",IF(ISBLANK(O5)=TRUE,""Missing PSD"",TODAY()-O5))
This should be calculated until the last row of Date1 column.
Kindly share any knowledge you have on this, it'd be very helpful.
Sub FillFormula()
Set wb = ActiveWorkbook
Dim sh As Worksheet, lastRow As Long
Set sh = wb.Worksheets("Sheet1")
lastRow = sh.Range("O" & Rows.count).End(xlUp).Row 'chosen O:O column, being involved in the formula...
sh.Range("AC5:AC" & lastRow).Formula = "=IF(ISBLANK(B5),"""",IF(ISBLANK(O5)=TRUE,""Missing PSD"",TODAY()-O5))"
lastRow2 = sh.Range("R" & Rows.count).End(xlUp).Row
sh.Range("AD5:AD" & lastRow).Formula = "=IF(ISBLANK(B5),"""",IF(ISBLANK(R5)=TRUE,""Missing RSD"",TODAY()-R5))"
End Sub
This is the code I am currently using and it works properly but my columns might change so I do not want to use the column character but instead the column name to paste the data into the correct column.
Try the next code, please. It still calculates the last row based on O:O column. If the column "Date1" has already formulas to be overwritten, I can easily adapt the code to use it:
Sub FillFormulaByHeader()
Dim wb As Workbook, sh As Worksheet, lastRow As Long, celD As Range
Set wb = ActiveWorkbook
Set sh = wb.Worksheets("Sheet1")
'Find the header ("Date1"):
Set celD = sh.Range(sh.Range("A1"), sh.cells(, cells(1, Columns.count).End(xlToLeft).Column)).Find("Date1")
If celD Is Nothing Then MsgBox "Nu such header could be found...": Exit Sub
lastRow = sh.Range("O" & rows.count).End(xlUp).row 'it can be easily changed for column with Date1 header
sh.Range(sh.cells(5, celD.Column), sh.cells(lastRow, celD.Column)).Formula = _
"=IF(ISBLANK(B5),"""",IF(ISBLANK(O5)=TRUE,""Missing PSD"",TODAY()-O5))"
End Sub
For simplicity, let's assume you have Headers in Row1. We now need to find out which column our Date1 Value is in. We can do this by simply looping over the Header Range an check if the Value equals "Date1". Now we can use this information to construct the final Range.
Sub FindDate1()
Dim c As Range
Dim date1Column as integer
Dim finalRange As Range
For Each c In Range("A1:Z1")
If c.Value = "Date1" Then
date1Column = c.Column
Exit For
End If
Next c
If date1Column = 0 Then
'in case "Date1" was not found
Exit Sub
Else
Set finalRange = Range(Cells(2, date1Column), Cells(2, date1Column).End(xlDown))
For Each c In finalRange
c.Formula = "=IF(ISBLANK(B" & c.Row & "),"""",IF(ISBLANK(O" & c.Row & ")=TRUE,""Missing PSD"",TODAY()-O" & c.Row & "))"
Next c
End If
End Sub
(not in a range, not adjacent columns)
(in given order)
I have many rows on Sheet1. I would like to copy some columns of a row (not the entire row and not a range of columns) to Sheet2 (to the first empty row of Sheet2) if a cell satisfies a condition (the cell in the current row and A column has a value of y)
I would like to copy not the entire row from Sheet1 only the row with those columns that are given on Sheet3 (Column A), and the new column number (on Sheet2) is also given on Sheet3 (column B)
It would be simple if my task would be to copy the entire row, or the selected column would be in a range...but i would need to copy those columns that are specialized on Sheet3. I would be grateful for any help. Thanks in advance.
Sheet1 shows an example data sheet. The criteria is if Cells(Rows, 1).Value = "y"
Sheet2 shows the desired result.
Sheet3 shows the selected column number on Sheet1 and the new column number on Sheet2
Whilst this probably should be done using arrays more, here's some basic VBA code that loops the first sheet checking for "y" in the first column. When it finds it, it then loops the column mappings in the third sheet that have been saved into arrays to set the values on the second sheet:
Sub sTranasferData()
On Error GoTo E_Handle
Dim aOld() As Variant
Dim aNew() As Variant
Dim wsIn As Worksheet
Dim wsOut As Worksheet
Dim wsTrack As Worksheet
Dim lngLastRow As Long
Dim lngLoop1 As Long
Dim lngLoop2 As Long
Dim lngRow As Long
Dim lngTrack As Long
Set wsIn = Worksheets("Sheet1")
Set wsOut = Worksheets("Sheet2")
Set wsTrack = Worksheets("Sheet3")
lngLastRow = wsIn.Cells(wsIn.Rows.Count, "A").End(xlUp).Row
lngTrack = wsTrack.Cells(wsTrack.Rows.Count, "A").End(xlUp).Row
aOld() = wsTrack.Range("A2:A" & lngTrack).Value
aNew() = wsTrack.Range("B2:B" & lngTrack).Value
lngRow = 1
For lngLoop1 = 2 To lngLastRow
If wsIn.Cells(lngLoop1, 1) = "y" Then
For lngLoop2 = LBound(aOld) To UBound(aOld)
wsOut.Cells(lngRow, aNew(lngLoop2, 1)) = wsIn.Cells(lngLoop1, aOld(lngLoop2, 1))
Next lngLoop2
lngRow = lngRow + 1
End If
Next lngLoop1
sExit:
On Error Resume Next
Set wsIn = Nothing
Set wsOut = Nothing
Set wsTrack = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sTransferData", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Regards,
I have two questions
How to combine data using two of the cells from workbookA and copy to workbookB on the same cell?
How do I start using for loop to copy it until the last row/column?
I have no clue on how to combine the data and I do not know where to place the variable inside the code for it to loop until its last column.
Dim Tlastrow As Integer
Tlastrow = Cells(1, Columns.Count).End(xlToLeft).Column
For r = 1 To Tlastrow
Workbooks("InputB.xls").Worksheets("HC_MODULAR_BOARD_20180112").Range("F3:G3").Copy _
Workbooks("Output.xls").Worksheets("Sheet1").Range("I3")
Next
Try this:
Option Explicit
Sub Paste()
Dim wsInput As Worksheet, wsOutput As Worksheet, LastRow As Long, C As Range
Set wsInput = Workbooks("InputB.xls").Worksheets("HC_MODULAR_BOARD_20180112")
Set wsOutput = Workbooks("Output.xls").Worksheets("Sheet1")
With wsInput
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row 'Last Row with data
For Each C In .Range("F3:F" & LastRow) 'loop for every row with data
wsOutput.Cells(C.Row, "I").Value = C & " " & C.Offset(0, 1)
Next C
End With
End Sub
This code is assuming you want to paste every row from your input workbook to the output workbook on the same rows, but merging F and G columns. It's just pasting the values, not formulas or formats.
Intended Result
If a row in a table contains any of the listed strings in column L on Sheet1, Then copy the entire row from Sheet1 and paste the row into a duplicate table on Sheet2 (which would be blank at the beginning).
(UNINTERESTED, UNRELATED, UNDECIDED, etc...)
Then delete the entire row that was transferred from sheet 1.
After macro runs, the new transfers should not reset table on Sheet2, rather add rows on the pre-existing lines. This document would be utilized over months.
Variables
Sheet1 is named Pipeline_Input
Sheet2 is named Closed_Sheet
Sheet1 table is named tblData
Sheet2 table is named tblClosed
Images
Image 1 is the code with error
Image 2 is Sheet 1 with some picture explanation
Image 3 is Sheet 2 with some picture explanation
Current Result
Run-time error '1004':
Application-defined or object-defined error
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_input As Worksheet 'where is the data copied from
Dim Closed_Sheet As Worksheet 'where is the data pasted to
Dim strPhase() As String
Dim i As Integer
Dim intPhaseMax As Integer
Dim lngLstRow As Long
Dim rngCell As Range
Dim finalrow As Integer
Dim lr As Long 'row counter
Dim Looper As Integer
intPhaseMax = 6
ReDim strPhase(1 To intPhaseMax)
strPhase(1) = "LOST"
strPhase(2) = "BAD"
strPhase(3) = "UNINTERESTED"
strPhase(4) = "UNRELATED"
strPhase(5) = "UNDECIDED"
strPhase(6) = "BUDGET"
'set variables
Set Pipeline_input = Sheet1
Set Closed_Sheet = Sheet2
lr = Range("A" & Rows.Count).End(xlUp).Row
For Looper = LBound(strPhase) To UBound(strPhase)
For i = lr To 6 Step -1
Next
If Not Sheet1.Range("L9:L300" & lngLstRow).Find(strPhase(Looper), lookat:=xlWhole) Is Nothing Then
Range(Cells(i, 1), Cells(i, 20)).Copy
Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
Range(Cells(i, 1), Cells(i, 20)).Delete
End If
Next
Sheet2.Select
Sheet2.columns.AutoFit
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Okay, there were a plethora of issues with the code you posted, but I decided to help you out here - Notice a few things - There's no copying and pasting here - we're just transferring data.
Secondly, use easy to understand variables. lr and lngLastRow can't be distinguished from one another, so classify them by which worksheet you're getting that value from.
We create an array in one fell swoop here - Just declare a variant and place our values in. ARRAYS (TYPICALLY) START AT ZERO, NOT ONE, so our loop starts at 0 :). Again, this is what's known as best practice...
I swapped out Looper for j. Again, keep. it. simple!
EDIT: I tested this code out on a simulated workbook and it worked fine - should run into no issues for you either.
EDIT2: Also, always use Option Explicit!
Option Explicit
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_Input As Worksheet 'source sheet
Dim Closed_Sheet As Worksheet 'destination sheet
Dim i As Long, j As Long, CSlastrow As Long, PIlastrow As Long
Dim strPhase As Variant
'Here we create our array
strPhase = Array("LOST", "BAD", "UNINTERESTED", "UNRELATED", "UNDECIDED", "BUDGET")
'Assign worksheets
Set Pipeline_Input = ActiveWorkbook.Worksheets("Pipeline_Input")
Set Closed_Sheet = ActiveWorkbook.Worksheets("Closed_Sheet")
PIlastrow = Pipeline_Input.Range("A" & Rows.Count).End(xlUp).Row
For j = 0 To UBound(strPhase)
For i = PIlastrow To 6 Step -1
If Pipeline_Input.Range("L" & i).Value = strPhase(j) Then
'Refresh lastrow value
CSlastrow = Closed_Sheet.Range("A" & Rows.Count).End(xlUp).Row
'Transfer data
Closed_Sheet.Range("A" & CSlastrow + 1 & ":S" & CSlastrow + 1).Value = _
Pipeline_Input.Range("A" & i & ":S" & i).Value
'Delete the line
Pipeline_Input.Range("A" & i & ":S" & i).EntireRow.Delete
End If
Next i
Next j
Closed_Sheet.Select
Closed_Sheet.Columns.AutoFit
Application.ScreenUpdating = True
End Sub