I need to copy the Employee Name in Column I until a new Employee Comes up. For example, Copy Brown, Nat till row 8 i.e. Code: Shift 1, then start copying Brown, Rob. I used If with find function but i cant make it work.
Your question is mighty short on detail but the function below should help you get one step nearer to what you need. Please try it.
Private Function EmployeeData(ByVal FirstRow As Long) As Variant
' 233
Dim Arr As Variant
Dim Cl As Long ' last used column
Dim R As Long ' lop counter: rows
With Worksheets("Sheet1")
Arr = .Range(.Cells(1, "I"), .Cells(.Rows.Count, "I").End(xlUp)).Value
R = FirstRow
Do
If InStr(1, Arr(R + 1, 1), "Employee Name:", vbTextCompare) = 1 Then Exit Do
R = R + 1
Loop While R < UBound(Arr)
With .UsedRange
Cl = .Columns.Count + .Column - 1
End With
EmployeeData = .Range(.Cells(FirstRow, "A"), .Cells(R, Cl)).Value
End With
End Function
The function takes one argument. That is the number of the row where the employee's name is first found. Starting from that row, the function searches until the next name is found in column I and returns the data from the rows in between. It returns all data, from column A to the last used column.
Use the procedure below to test. Observe that EmployeeData(14) specifies row 14 as the first row of a block and that the loop that follows just prints column I:I although the array contains all the columns.
Sub GetData()
' 233
Dim Arr As Variant
Dim R As Long
Arr = EmployeeData(14)
For R = 1 To UBound(Arr)
Debug.Print Arr(R, 9)
Next R
End Sub
In real life, you will probably need to search for the first row before you can run this code. That search, if needed, is easy to integrate into the test procedure.
Related
I am new to VBA and am trying to copy the column from Row 2 onwards where the column header (in Row 1) contains a certain word- "Unique ID".
Currently what I have is:
Dim lastRow As Long
lastRow = ActiveWorkbook.Worksheets("Sheets1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheets1").Range("D2:D" & lastRow).Copy
But the "Unique ID" is not always in Column D
You can try following code, it loops through first row looking for a specified header:
Sub CopyColumnWithHeader()
Dim i As Long
Dim lastRow As Long
For i = 1 To Columns.Count
If Cells(1, i) = "Unique ID" Then
lastRow = Cells(Rows.Count, i).End(xlUp).Row
Range(Cells(2, i), Cells(lastRow, i)).Copy Range("A2")
Exit For
End If
Next
End Sub
When you want to match info in VBA you should use a dictionary. Additionally, when manipulating data in VBA you should use arrays. Although it will require some learning, below code will do what you want with minor changes. Happy learning and don't hesitate to ask questions if you get stuck:
Option Explicit
'always add this to your code
'it will help you to identify non declared (dim) variables
'if you don't dim a var in vba it will be set as variant wich will sooner than you think give you a lot of headaches
Sub DictMatch()
'Example of match using dictionary late binding
'Sourcesheet = sheet1
'Targetsheet = sheet2
'colA of sh1 is compared with colA of sh2
'if we find a match, we copy colB of sh1 to the end of sh2
'''''''''''''''''
'Set some vars and get data from sheets in arrays
'''''''''''''''''
'as the default is variant I don't need to add "as variant"
Dim arr, arr2, arr3, j As Long, i As Long, dict As Object
'when creating a dictionary we can use early and late binding
'early binding has the advantage to give you "intellisense"
'late binding on the other hand has the advantage you don't need to add a reference (tools>references)
Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
dict.CompareMode = 1 'textcompare
arr = Sheet1.Range("A1").CurrentRegion.Value2 'load source, assuming we have data as of A1
arr2 = Sheet2.Range("A1").CurrentRegion.Value2 'load source2, assuming we have data as of A1
'''''''''''''''''
'Loop trough source, calculate and save to target array
'''''''''''''''''
'here we can access each cell by referencing our array(<rowCounter>, <columnCounter>
'e.g. arr(j,i) => if j = 1 and i = 1 we'll have the values of Cell A1
'we can write these values anywhere in the activesheet, other sheet, other workbook, .. but to limit the number of interactions with our sheet object we can also create new, intermediant arrays
'e.g. we could now copy cel by cel to the new sheet => Sheets(arr(j,1).Range(... but this would create significant overhead
'so we'll use an intermediate array (arr3) to store the results
'We use a "dictionary" to match values in vba because this allows to easily check the existence of a value
'Together with arrays and collections these are probably the most important features to learn in vba!
For j = 1 To UBound(arr) 'traverse source, ubound allows to find the "lastrow" of the array
If Not dict.Exists(arr(j, 1)) Then 'Check if value to lookup already exists in dictionary
dict.Add Key:=arr(j, 1), Item:=arr(j, 1) 'set key if I don't have it yet in dictionary
End If
Next j 'go to next row. in this simple example we don't travers multiple columns so we don't need a second counter (i)
'Before I can add values to a variant array I need to redim it. arr3 is a temp array to store matching col
'1 To UBound(arr2) = the number of rows, as in this example we'll add the match as a col we just keep the existing nr of rows
'1 to 1 => I just want to add 1 column but you can basically retrieve as much cols as you want
ReDim arr3(1 To UBound(arr2), 1 To 1)
For j = 1 To UBound(arr2) 'now that we have all values to match in our dictionary, we traverse the second source
If dict.Exists(arr2(j, 1)) Then 'matching happens here, for each value in col 1 we check if it exists in the dictionary
arr3(j, 1) = arr(j, 2) 'If a match is found, we add the value to find back, in this example col. 2, and add it to our temp array (arr3).
'arr3(j, 2) = arr(j, 3) 'As explained above, we could retrieve as many columns as we want, if you only have a few you would add them manually like in this example but if you have many we could even add an additional counter (i) to do this.
End If
Next j 'go to the next row
'''''''''''''''''
'Write to sheet only at the end, you could add formatting here
'''''''''''''''''
With Sheet2 'sheet on which I want to write the matching result
'UBound(arr2, 2) => ubound (arr2) was the lastrow, the ubound of the second dimension of my array is the lastcolumn
'.Cells(1, UBound(arr2, 2) + 1) = The startcel => row = 1, col = nr of existing cols + 1
'.Cells(UBound(arr2), UBound(arr2, 2) + 1)) = The lastcel => row = number of existing rows, col = nr of existing cols + 1
.Range(.Cells(1, UBound(arr2, 2) + 1), .Cells(UBound(arr2), UBound(arr2, 2) + 1)).Value2 = arr3 'write target array to sheet
End With
End Sub
I apologize, this is my first crack at Excel VBA so excuse my lack of knowledge!
So I have a list of (currently) 3 names to assign to the days in column A in a repeating order in Excel.
Currently my VBA code allows it to populate the selected cells with the names in a repeating pattern (this part is good), however there are two pieces I need help with.
1- with current code, once it reaches the bottom of the names it checks for the blank box that would end that list and starts over at the tops as directed but it puts a blank cell first (see screenshot). How can I have it put next name without adding blank cell first?
2- I want to be able to (once this gets going)select the entire D column through what dates need to be filled and:
-check the lowest non blank box
-match to list and set the
counter to name below that so
it continues the name order
from the last person who was
assigned
This is code I have now:
Sub EXAMPLE()
Dim count As Integer
count = 0
For Each c In Selection
c.Value = Range("X1").Offset(count, 0).Value
If c.Value = "" Then count = -1 And c.Value = Range("x1").Offset(count, 0).Value
count = count + 1
Next c
End Sub
Sorry I know that was long, I hope this makes sense.
I think it's worth reading about arrays, as this task is ideally suited to their use. Your best bet would be to read the names into an array and then build a recurring array whose dimension is equal to the number of rows in your dates column (or selection, or however you want to define the size of the output range).
Code would look a little like this:
Dim v As Variant
Dim people() As Variant, output() As Variant
Dim rowCount As Long, i As Long, j As Long
Dim endRange As Range
'Read the list of names into an array.
'This just takes all data in column "X" -> amend as desired
With Sheet1
Set endRange = .Cells(.Rows.Count, "X").End(xlUp)
v = .Range(.Cells(1, "X"), endRange).Value
End With
'Sense check on the names data.
If IsEmpty(v) Then
MsgBox "No names in Column ""X"""
Exit Sub
End If
If Not IsArray(v) Then
ReDim people(1 To 1, 1 To 1)
people(1, 1) = v
Else
people = v
End If
'Acquire the number of rows for repeating list of names.
'This just takes all data in column "A" -> amend as desired
With Sheet1
Set endRange = .Cells(.Rows.Count, "A").End(xlUp)
rowCount = .Range(.Cells(3, "A"), endRange).Rows.Count
End With
'Sense check date data.
If endRange.Row < 3 Then
MsgBox "No dates in Column ""A"""
Exit Sub
End If
'Make a recurring array.
ReDim output(1 To rowCount, 1 To 1)
i = 1
Do While i <= rowCount
For j = 1 To UBound(people, 1)
output(i, 1) = people(j, 1)
i = i + 1
If i > rowCount Then Exit Do
Next
Loop
'Write the output to column "D"
Sheet1.Range("D3").Resize(UBound(output, 1)).Value = output
example data
I have four columns of data, two of these are names (A and D). One (B) is total work hours, and one (E) is time in training.
Can I write a function which does this:
Writes the value of column E in column C in the right place, i.e. "41" in row 2, "32.8" in row 5 and "24.6" in row 8.
thank you.
i just quickly put something together, but it works, you may need to tweak it to use your sheet name etc....
Private Sub FindNames()
Dim RngArr As Variant
Dim i As Long, j As Long
Dim Rws As Long
Dim FRw As Long
'Sheet1 here is not the tab name, but the CodeName (in VBA its the name not in brackets in project explorer)
RngArr = Sheet1.UsedRange.Value 'get range array
If Not IsArray(RngArr) Then Exit Sub 'either a single cell is used or something is wrong
FRw = Sheet1.UsedRange.Row
Rws = UBound(RngArr, 1) - 1 'get total rows in range minus 1
For i = FRw To FRw + Rws 'loop for the list in D:E
If Not RngArr(i, 4) = vbnulstring Then
For j = FRw To FRw + Rws 'loop for the list in A:B (C)
'if ColD = ColA then ColC = ColE
If RngArr(i, 4) = RngArr(j, 1) Then RngArr(j, 3) = RngArr(i, 5)
Next j
Else
'you could exit the loop here if you list will never have empty spaces to save time although you wont notice
End If
Next i
Sheet1.UsedRange.Value = RngArr 'since we are resizing the original used space we can just dump the results back
End Sub
Hope this helps
Paul S.
I need to find a way to split some data on excel: e.g.
If a cell has the following in: LWPO0001653/1654/1742/1876/241
All of the info after the / should be LWPO000... with that number.
Is there anyway of separating them out and adding in the LWPO000in? So they come out as LWPO0001653
LWPO0001654
etc etc
I could do manually yes, but i have thousands to do so would take a long time.
Appreciate your help!
Here is a solution using Excel Formulas.
With your original string in A1, and assuming the first seven characters are the one's that get repeated, then:
B1: =LEFT($A1,FIND("/",$A1)-1)
C1: =IF(LEN($A1)-LEN(SUBSTITUTE($A1,"/",""))< COLUMNS($A:A),"",LEFT($A1,7)&TRIM(MID(SUBSTITUTE(MID($A1,8,99),"/",REPT(" ",99)),(COLUMNS($A:A))*99,99)))
Select C1 and fill right as far as required. Then Fill down from Row 1
EDIT: For a VBA solution, try this code. It assumes the source data is in column A, and puts the results adjacent starting in Column B (easily changed if necessary). It works using arrays within VBA, as doing multiple worksheet read/writes can slow things down. It will handle different numbers of splits in the various cells, although could be shortened if we knew the number of splits was always the same.
Option Explicit
Sub SplitSlash()
Dim vSrc As Variant
Dim rRes As Range, vRes() As Variant
Dim sFirst7 As String
Dim V As Variant
Dim COL As Collection
Dim I As Long, J As Long
Dim lMaxColCount As Long
Set rRes = Range("B1") 'Set to A1 to overwrite
vSrc = Range("a1", Cells(Rows.Count, "A").End(xlUp))
'If only a single cell, vSrc won't be an array, so change it
If Not IsArray(vSrc) Then
ReDim vSrc(1 To 1, 1 To 1)
vSrc(1, 1) = Range("a1")
End If
'use collection since number of columns can vary
Set COL = New Collection
For I = 1 To UBound(vSrc)
sFirst7 = Left(vSrc(I, 1), 7)
V = Split(vSrc(I, 1), "/")
For J = 1 To UBound(V)
V(J) = sFirst7 & V(J)
Next J
lMaxColCount = IIf(lMaxColCount < UBound(V), UBound(V), lMaxColCount)
COL.Add V
Next I
'Results array
ReDim vRes(1 To COL.Count, 1 To lMaxColCount + 1)
For I = 1 To UBound(vRes, 1)
For J = 0 To UBound(COL(I))
vRes(I, J + 1) = COL(I)(J)
Next J
Next I
'Write results to sheet
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.EntireColumn.AutoFit
End With
End Sub
I'm clearly missing the point :-) but anyway, in B1 and copied down to suit:
=SUBSTITUTE(A1,"/","/"&LEFT(A1,7))
Select ColumnB, Copy and Paste Special, Values over the top.
Apply Text to Columns to ColumnB, Delimited, with / as the delimiter.
There's a couple of ways to solve this. The quickest is probably:
Assuming that the data is in column A:
Highlight the column, go to Data>>Text To Columns
Choose "Delimited" and in the "Other" box, put /
Click ok. You'll have your data split into multiple cells
Insert a column at B and put in the formula =Left(A1, 7)
Insert a column at C and pit in formula =Right(A1, Length(A1)-7)
You'll now have Column B with your first 7 characters, and columns B,C,D,E,F, etc.. with the last little bit. You can concatenate the values back together for each column you have with =Concatenate(B1,C1), =Concatenate(B1,D1), etc..
A quick VBa, which does nearly the same thing that #Kevin's does as well. I wrote it before I saw his answer, and I hate to throw away work ;)
Sub breakUpCell()
Dim rngInput As Range, rngInputCell As Range
Dim intColumn As Integer
Dim arrInput() As String
Dim strStart As String
Dim strEnd As Variant
'Set the range for the list of values (Assuming Sheet1 and A1 is the start)
Set rngInput = Sheet1.Range("A1").Resize(Sheet1.Range("A1").End(xlDown).Row)
'Loop through each cell in the range
For Each rngInputCell In rngInput
'Split up the values after the first 7 characters using "/" as the delimiter
arrInput = Split(Right(rngInputCell.Value, Len(rngInputCell.Value) - 7), "/")
'grab the first 7 characters
strStart = Left(rngInputCell.Value, 7)
'We'll be writing out the values starting in column 2 (B)
intColumn = 2
'Loop through each split up value and assign to strEnd
For Each strEnd In arrInput
'Write the concatenated value out starting at column B in the same row as rngInputCell
Sheet1.Cells(rngInputCell.Row, intColumn).Value = strStart & strEnd
'Head to the next column (C, then D, then E, etc)
intColumn = intColumn + 1
Next strEnd
Next rngInputCell
End Sub
Here is how you can do it with a macro:
This is what is happening:
1) Set range to process
2) Loop through each cell in range and check it isn't blank
3) If the cell contains the slash character then split it and process
4) Skip the first record and concatenate "LWPO000" plus the current string to adjacent cells.
Sub CreateLWPO()
On Error Resume Next
Application.ScreenUpdating = False
Dim theRange
Dim cellValue
Dim offset As Integer
Dim fields
'set the range of cells to be processed here
Set theRange = range("A1:A50")
'loop through each cell and if not blank process
For Each c In theRange
offset = 0 'this will be used to offset each item found 1 cell to the right (change this number to this first column to be populated)
If c.Value <> "" Then
cellValue = c.Value
If InStr(cellValue, "/") > 0 Then
fields = Split(cellValue, "/")
For i = 1 To UBound(fields)
offset = offset + 1
cellValue = "LWPO000" & fields(i)
'if you need to pad the number of zeros based on length do this and comment the line above
'cellValue = "LWPO" & Right$(String(7, "0") & fields(i), 7)
c.offset(0, offset).Value = cellValue
Next i
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Below is a snippet of the table I'm working with.
From left to write I need to know how I can the entire second column appended to the first one. So, starting at V5789 of the second column, that and all of the contents below it need to be placed after the V854 in the first column. The third column needs to be 'stacked'onto the bottom of the second one. So 2 appends to 1, 3 appends to 2, 4 appends to 3. etc.
Any clues?
Hows this for an alternative? Only has 2 calls to the worksheet and one loop.
Sub append()
Dim g, newArray
Dim strJoin As String
Dim x As Integer
g = Sheet1.Cells(1, 1).CurrentRegion.Value
For x = 1 To UBound(g, 2)
strJoin = strJoin & Replace(Join(Application.Transpose(Application.Index(g, 0, x)), "~/"), "/~", "")
If Right(strJoin, 2) <> "~/" And x <> UBound(g, 2) Then strJoin = strJoin & "~/"
Next x
newArray = Split(strJoin, "~/")
Columns(1).Cells(1).Resize(UBound(newArray) + 1).Value = Application.Transpose(newArray)
End Sub
Try this:
Sub DoooooooooIT()
Dim col As Range, _
found As Range
Dim currRow As Integer
currRow = ActiveSheet.Range("A:A").Find("", after:=ActiveSheet.Range("A1"), lookat:=xlWhole, searchdirection:=xlNext).Row
For Each col In ActiveSheet.UsedRange.Columns
If col.Column <> 1 Then
Set found = col.EntireColumn.Find("", after:=col.Cells(1, 1), lookat:=xlWhole, searchdirection:=xlNext)
Set found = ActiveSheet.Range(col.Cells(1, 1), found)
found.Copy
ActiveSheet.Cells(currRow, 1).PasteSpecial
currRow = currRow + found.Cells.Count - 1
End If
Next col
End Sub
I would go about this by using 2 for loops: outer loop will start your counting variable at 2, then iterate up with a step of 1. This is iterating through your columns.
in that loop, have a nested for loop that iterates through each row of the unique columns. It will iterate from row one and down, checking each loop if the cell at the position given by the outer loop's column and inner loop's row has anything in it (so check if cell.value = ""). Once it finds the first empty cell in that column, have it copy everything from row 3 until the row counting variable in the outer loop's column and paste it into the previous column at row 3.
I have provided pseudo-code instead of the actual code because I don't believe this would be too difficult to write yourself and I don't have time to at this moment, so you may be able to do it sooner than I will have a chance too. However, if you want further assistance let me know and I can work on some code for you when I have a chance.
edit: forgot to add, make sure to include something to deal with the unique position of where the second column data needs to go into the first column. likely best if you just include something like "if PasteToColumn = 1 then paste into cell A9" or something similar
EDIT again: here's my new and improved version! let me know what you think/if it works
Sub MoveStuff()
Dim rowcounter As Integer
Dim columncounter As Integer
rowcounter = 1
columncounter = 2
Do While Cells(rowcounter, columncounter).Value <> ""
Do While Cells(rowcounter, columncounter).Value <> ""
rowcounter = rowcounter + 1
Loop
Range(Cells(3, columncounter), Cells(rowcounter - 1, columncounter)).Cut (Columns(columncounter - 1).End(xlDown).Offset(rowoffset:=1))
columncounter = columncounter + 1
rowcounter = 1
Loop
End Sub