If anyone has done anything like below please help.
What I'm looking for is macro that looks at my A2 value and copy that in column D based on value B with "_"(underscore) after it.
You would need 2 loops for this. One looping through column A and one counting up to the value in column B.
Option Explicit
Public Sub WriteValues()
With Worksheets("Sheet1")
Dim aLastRow As Long
aLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'get last used row in col A
Dim dRow As Long
dRow = 1 'start row in col D
Dim aRow As Long
For aRow = 1 To aLastRow 'loop through col A
Dim bCount As Long
For bCount = 1 To .Cells(aRow, "B").Value 'how many times is A repeated?
.Cells(dRow, "D").Value = .Cells(aRow, "A") & "_" & bCount 'write into column D
dRow = dRow + 1 'count rows up in col D
Next bCount
Next aRow
End With
End Sub
Your request is little short on particulars but this will do what you're asking.
dim i as long
with worksheets("sheet1")
for i=1 to .cells(2, "B").value2
.cells(.rows.count, "D").end(xlup).offset(1, 0) = .cells(2, "A").value & format(i, "\_0")
next i
end with
Related
please help i want to sort the name column such that each name starts after every blank cell.
I want it look something like this..pls help it's a pretty long column
Option Explicit
Sub SetNamePosition()
Dim arr As Variant
Dim i As Long: i = 1 ' for Loop
Dim j As Long: j = 1 ' for Array
Dim lastRow As Long: lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim rngColB As Range: Set rngColB = Range("B2:B" & lastRow)
Dim rngNames As Range: Set rngNames = Range("C1") ' Temporary range
' Get column B names only
rngColB.SpecialCells(xlCellTypeConstants, 2).Copy
rngNames.PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
Set rngNames = Range(rngNames, rngNames.End(xlDown))
' Load rngNames to array
arr = Application.Transpose(rngNames)
' Clear rng of column B and rngNames
rngColB.Clear
rngNames.Clear
' Insert names
For i = 2 To lastRow
' set name
Cells(i, 1).Offset(0, 1).Value = arr(j)
' find next cell
i = Cells(i, 1).End(xlDown).Row + 1
j = j + 1
Next i
End Sub
I's probably better to remove the empty ranges before making the array, but here's one way to distribute the names:
Loading the range ito an array, then go through the numbers and look for empty ranges.
This assumes that we are working with column "A" and "B" (1 and 2), starting at the top.
Sub test()
Dim arr As Variant
Dim lastRow As Long, i As Long, j As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
arr = Application.Transpose(Range("B2:B" & lastRow))
Range("B2:B" & lastRow).Clear
j = 1
For i = 2 To lastRow
Cells(i, 2) = arr(j)
j = j + 1
If j >= UBound(arr) Then Exit For
While arr(j) = "" And j < UBound(arr)
j = j + 1
Wend
While Not Cells(i, 1).Value = ""
i = i + 1
Wend
Next i
End Sub
Any leftover names will be removed
I am having a set of records highlighting the keywords with regards to the dates they were raised. I want to remove the duplicates in the rows and analyze the frequency of keywords on a pivot table with regards to the month they were raised.
I have used python-3 code to chunk out the keywords from the customer queries that were logged in the system. I am not sure how to strip it.
Sub RemoveDuplicatesInRow()
Dim lastRow As Long
Dim lastCol As Long
Dim r As Long 'row index
Dim c As Long 'column index
Dim i As Long
With ActiveSheet.UsedRange
lastRow = .Row + .Rows.Count - 1
lastCol = .Column + .Columns.Count - 1
End With
For r = 1 To lastRow
For c = 1 To lastCol
For i = c + 1 To lastCol 'change lastCol to c+2 will remove adjacent duplicates only
If Cells(r, i) <> "" And Cells(r, i) = Cells(r, c) Then
Cells(r, i) = ""
End If
Next i
Next c
Next r
End Sub
The macro just doesn't work.
I really don't understand much VBA, so be patient with me.
I have a list of people assigned to a specific flight (LEGID) and I want to copy those people (Worksheet pax) to a specific cell in another worksheet (temp - cell b15), but it doesn't work.
This data table is a query report from salesforce.
Sub pax()
Dim LastRow As Long
Dim i As Long, j As Long
Dim legid As String
Application.ScreenUpdating = False
legid = ThisWorkbook.Worksheets("setup").Range("SelReq").Value
Debug.Print legid
'Find the last used row in a Column: column A in this example
With Worksheets("pax")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
' MsgBox (LastRow)
'first row number where you need to paste values in temp'
With Worksheets("temp")
j = .Cells(.Rows.Count, "a").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("pax")
If .Cells(i, 1).Value = legid Then
.Rows(i).Copy Destination:=Worksheets("temp").Range("a" & j)
j = j + 1
End If
End With
Next i
Application.ScreenUpdating = True
End Sub
If you are looking to just get the names copied over. You can use this; however you will need to update your sheet names and ranges if they are named ranges. This code looks at a specific cell for a value on Sheet3 then if that value matches a value from a range on Sheet1 it will place the values from Column B on Sheet1 into Sheet2
Sub Test()
Dim cell As Range
Dim LastRow As Long, i As Long, j As Long
Dim legid As String
With Sheet1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With Sheet2
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
legid = Sheet3.Range("A1")
For i = 2 To LastRow
For Each cell In Sheet1.Range("A" & i)
If cell.Value = legid Then
Sheet2.Range("A" & j) = cell.Offset(0, 1).Value
j = j + 1
End If
Next cell
Next i
End Sub
I have a table consisting of strings and numbers. Row one contains the heading and row two contains the unit type (percent and dollars). I would like to round the numbers in the column based on the heading in row two.
At the moment I am selecting the columns individually. Is there a way to round the column based on the heading in row two?
Sub Round()
Dim Lastrow As Long
Lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row 'Determine
last row
For Each cell In ActiveSheet.Range("R3:R" & Lastrow)
cell.Value = WorksheetFunction.Round(cell.Value, 2) 'Round dollars to 2 places
Next cell
For Each cell In ActiveSheet.Range("AB3:AB" & Lastrow)
cell.Value = WorksheetFunction.Round(cell.Value, 2)
Next cell
For Each cell In ActiveSheet.Range("Q3:Q" & Lastrow)
cell.Value = WorksheetFunction.Round(cell.Value, 1) 'Round percentages to 1 places
Next cell
....
End Sub
You were close enough, just needed a bit from both of those tries together. Please see if the below helps, I've added an alternative using arrays as well (if you have lots of data, it will be much faster):
Sub RoundRanges()
Dim ws As Worksheet: Set ws = ActiveSheet 'better use something like: ActiveWorkbook.Sheets("Sheet name here")
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'get last row
Dim lCol As Long: lCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column 'get last column
Dim R As Long, C As Long
For C = 1 To lCol 'iterate through each column
Select Case ws.Cells(2, C) 'get the text of the cell 2...
Case "Percent"
For R = 3 To lRow 'iterate through each row
ws.Cells(R, C) = WorksheetFunction.Round(ws.Cells(R, C).Value, 1) 'apply the desired calculation
Next R
Case "Dollars"
For R = 3 To lRow 'iterate through each row
ws.Cells(R, C) = WorksheetFunction.Round(ws.Cells(R, C).Value, 2) 'apply the desired calculation
Next R
End Select
Next C
'ALTERNATIVE:
'Dim arrData As Variant: arrData = ws.Range(ws.Cells(1, 1), ws.Cells(lRow, lCol))
'For R = LBound(arrData) + 2 To UBound(arrData) 'skip first 2 rows
' For C = LBound(arrData, 2) To UBound(arrData, 2)
' If arrData(2, C) = "Percent" Then
' arrData(R, C) = Round(arrData(R, C), 1)
' ElseIf arrData(2, C) = "Dollars" Then
' arrData(R, C) = Round(arrData(R, C), 2)
' End If
' Next C
'Next R
'ws.Range(ws.Cells(1, 1), ws.Cells(lRow, lCol)) = arrData
End Sub
I've seen similar posts, but nothing that has directly addressed my current problem...
I have a workbook with 2 sheets (Sheet1 and Sheet 2). In Sheet1, there are 2 columns - column A contains part numbers from our old ERP system and column B contains weights. In Sheet2, I have 2 columns - column A contains part numbers from our new ERP system and column B contains alias part numbers.
I would like to have a macro read in the part number in Sheet1 (which sits in column A) and see if that value exists in Sheet2 in either column A or column B. If it finds a match, it would need to copy the corresponding weight to column C on Sheet2.
I am a novice at writing macros and I've attached a modified version of code posted to a similar problem. Any help would be greatly appreciated - thank you in advance to any replies.
Sub CopyCells()
Application.ScreenUpdating = False
Dim sh1 As Worksheet, sh2 As Worksheet
Dim j As Long, i As Long, lastrow1 As Long, lastrow2 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lastrow1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row
lastrow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow1
For j = 2 To lastrow2
If sh1.Cells(i, "A").Value = sh2.Cells(j, "A").Value Or _
sh1.Cells(i, "A").Value = sh2.Cells(j, "B").Value Then
sh1.Cells(i, "B").Value = sh2.Cells(j, "C").Value
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
This might help get you started. I am assuming you have data starting in row 1 in columns A and B of Sheet1 and Sheet2 and that you want to copy weights to Column C in Sheet2 :
Sub GetMatches()
Dim PartRngSheet1 As Range, PartRngSheet2 As Range
Dim lastRowSheet1 As Long, lastRowSheet2 As Long
Dim cl As Range, rng As Range
lastRowSheet1 = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
Set PartRngSheet1 = Worksheets("Sheet1").Range("A1:A" & lastRowSheet1)
lastRowSheet2 = Worksheets("Sheet2").Range("B65536").End(xlUp).Row
Set PartRngSheet2 = Worksheets("Sheet2").Range("A1:A" & lastRowSheet2)
For Each cl In PartRngSheet1
For Each rng In PartRngSheet2
If (cl = rng) Or (cl = rng.Offset(0, 1)) Then
rng.Offset(0, 2) = cl.Offset(0, 1)
End If
Next rng
Next cl
End Sub