Numbering every event which was splited from range to separate line - vba

I found a VBA code online which does the hardest part of splitting absences data from ranges to separate line for each day. But one thing I cannot figure out how to do it is how to assign a number to each day that was requested. Could anyone help me? For better understanding see screenshot. Greatly appreciated!
Yellow and Green coloured lines separates events. Orange is the thing I am trying to accomplish. Absences
Sub One_Day_Per_Row()
Dim a, b
Dim rws As Long, sr As Long, i As Long, j As Long, k As Long, r As Long
a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 6).Value
rws = UBound(a, 1)
For r = 1 To rws
a(r, 6) = a(r, 5) - a(r, 4) + 1
k = k + a(r, 6)
Next r
If k < Rows.Count Then
ReDim b(1 To k, 1 To 4)
sr = 1
For r = 1 To rws
For i = 0 To a(r, 6) - 1
For j = 1 To 3
b(sr + i, j) = a(r, j)
Next j
b(sr + i, 4) = a(r, 4) + i
Next i
sr = sr + a(r, 6)
Next r
Range("G2").Resize(k, 4).Value = b
Range("G1:J1").Value = Array("emp number", "emp name", "absence code", "date")
Else
MsgBox "Too many rows"
End If
End Sub

Something like this should work:
Sub Tester()
Dim data, rw As Long, ws As Worksheet, dStart, dEnd, d, n As Long
Dim cOut As Range
Set ws = ActiveSheet 'or whatever
'read the data
data = ws.Range("A2:E" & ws.Cells(Rows.Count, "A").End(xlUp).Row).Value
Set cOut = ws.Range("G2") 'cell to begin output
For rw = 1 To UBound(data, 1)
dStart = data(rw, 4) 'start date
dEnd = data(rw, 5) 'end date
n = 1 'reset counter
For d = dStart To dEnd 'loop date range
cOut.Resize(1, 3).Value = Array(data(rw, 1), data(rw, 2), data(rw, 3))
cOut.Offset(0, 3).Value = d
cOut.Offset(0, 4).Value = n
n = n + 1
Set cOut = cOut.Offset(1, 0) 'next output row
Next d
Next rw
End Sub

Related

Loading data range or string from excel file to an array then split in array

Is there someone can help me? I have here code that can duplicate entire row to have 2 rows. After duplicating the first entire row , I want to load string from range "G" into array so that I can get certain string that Am planning to insert in "Thickness" and "width" column for me to use to calculate the "Weight" of the "Profile Type". If you will see I have an array in the code .But that array work differently for me and I had a hard time fulfilling the requirements I need. The array in my code split the String using "X" as delimiter . Once the string was split it will add another cells for each split string. what I want is to do the split not in the column but in the array only so that I can maintain the data in G . I will use the string assigned in the array to get "Thickness and Width" of the profile which is "15 as Thickness and 150 as width". If there's any way to do same thing using other code it will be more helpful to simplify the code.
Reminder that Profiletype string vary its length . Sometimes profile width are 4 digits (LB1000X4500X12/15)
Below are the snapshot of my worksheet for you to identify what the result will be.
Private Sub CommandButton2_Click()
Dim lastrow As Long
Dim i As Integer
Dim icount As Integer
Dim x As Long
For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1
If Cells(x, "F") = "LB" Then
Cells(x, "F") = "ComP"
Cells(x + 1, "F").EntireRow.Insert
Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow
'array
'Columns("G:G").NumberFormat = "#"
Dim c As Long, r As Range, v As Variant, d As Variant
For i = 2 To Range("G" & Rows.Count).End(xlUp).Row '2 to 16 cell
'v = Split (range("G" & i), "X")
v = Split((Cells(x, "G") & i), "x")
c = c + UBound(v) + 1
'Next i
For i = 2 To c
If Range("G" & i) <> "" Then
Set r = Range("G" & i)
Dim arr As Variant
arr = Split(r, "X")
Dim j As Long
r = arr(0)
For j = 1 To UBound(arr)
Rows(r.Row + j & ":" & r.Row + j).Insert Shift:=xlDown
r.Offset(j, 0) = arr(j)
r.Offset(j, -1) = r.Offset(0, -1)
r.Offset(j, -2) = r.Offset(0, -2)
Next j
End If
Next i
End If
Next x
End Sub
Does this do what you want? Run in copy of workbook to be safe.
Option explicit
Private Sub CommandButton2_Click()
'Bit redundant, would be better if you fully qualify workbook and worksheet with actual names.'
Dim TargetWorksheet as worksheet
Set TargetWorksheet = Activesheet
With application
.screenupdating = false
.calculation = xlcalculationmanual
End with
With TargetWorksheet
.range("G:G").numberformat = "#"
Dim RowIndex As Long
For RowIndex = .usedrange.rows.countlarge to 1 step -1
If .Cells(RowIndex, "F").value2 = "LB" Then
.Cells(RowIndex, "F").value2 = "ComP"
.Cells(RowIndex + 1, "F").EntireRow.Insert
.Cells(RowIndex, "F").EntireRow.Copy .Cells(RowIndex + 1, "F").EntireRow
Dim SplitProfileType() as string
SplitProfileType = split(mid(.cells(RowIndex+1,"G").value2,3), "X") ' assumes first two characters will always be LB, that it is safe to ignore them and start from third character.'
' Write thickness'
.cells(RowIndex+1, "H").value2 = cdbl(mid(SplitProfileType(ubound(SplitProfileType)),instrrev(SplitProfileType(ubound(SplitProfileType)),"/",-1,vbbinarycompare)+1)
' Write width'
.cells(RowIndex+1, "i").value2 = cdbl(SplitProfileType(1))
' Calculate weight'
.cells(RowIndex+1,"K").value2 = .cells(RowIndex+1,"H").value2 * .cells(RowIndex+1,"I").value2 * .cells(RowIndex+1,"J").value2
End if
' I think because you are inserting a row below (rather than above/before), your RowIndex remains unaffected and no adjustment is needed to code. I could be wrong. I would need to test it to be sure.'
Next rowindex
End with
With application
.screenupdating = true
.calculation = xlcalculationautomatic
End with
End sub
Untested as written on mobile.
It works without duplication.
Sub test2()
Dim vDB, vR()
Dim i As Long, n As Long, k As Long, j As Integer
Dim r As Integer
Dim s As String
vDB = Range("A2", "K" & Range("A" & Rows.Count).End(xlUp).Row)
n = UBound(vDB, 1)
For i = 1 To n
If vDB(i, 6) = "LB" Then
r = 2
Else
r = 1
End If
k = k + r
ReDim Preserve vR(1 To 11, 1 To k)
s = vDB(i, 7)
For j = 1 To 11
If r = 1 Then
vR(j, k) = vDB(i, j)
Else
vR(j, k - 1) = vDB(i, j)
vR(j, k) = vDB(i, j)
End If
Next j
If r = 2 Then
vR(6, k - 1) = "comp"
vR(6, k) = "comp"
vR(8, k) = Split(s, "/")(1)
vR(9, k) = Split(s, "X")(1)
vR(9, k - 1) = vR(9, k - 1) - vR(8, k)
vR(11, k - 1) = (vR(8, k - 1) * vR(9, k - 1) * vR(10, k - 1) * 7.85) / 10 ^ 6 '<~~ k2 weight
vR(11, k) = (vR(8, k) * vR(9, k) * vR(10, k) * 7.85) / 10 ^ 6 '<~~ k3 weight
End If
Next i
Range("f1") = "Type"
Range("a2").Resize(k, 11) = WorksheetFunction.Transpose(vR)
End Sub
It is faster to use an array than to enter it one-to-one in a cell.
Sub test()
Dim vDB, vR()
Dim i As Long, n As Long, k As Long, j As Integer
Dim s As String
vDB = Range("A2", "K" & Range("A" & Rows.Count).End(xlUp).Row)
n = UBound(vDB, 1)
ReDim vR(1 To n * 2, 1 To 11)
For i = 1 To n
k = k + 2
s = vDB(i, 7)
For j = 1 To 11
vR(k - 1, j) = vDB(i, j)
vR(k, j) = vDB(i, j)
Next j
vR(k - 1, 6) = "comp"
vR(k, 6) = "comp"
vR(k, 8) = Split(s, "/")(1)
vR(k, 9) = Split(s, "X")(1)
vR(k, 11) = Empty '<~~ This is calculated Weight value place
Next i
Range("f1") = "Type"
Range("a2").Resize(n * 2, 11) = vR
End Sub

Only transpose data to a new column if it is a new group of data / excel vba

I have a column of data in excel which could potentially have data over 2000 rows. In that data there is groups of data that I would like to send to the top of a new column every time a new group is found. I've looked at the special paste option for transpose along with using a delimiter but i can only move data one column over and not to the top. I'm looking for a solution which is fast due to the amount of data that would need to be split into new columns. I appreciate the help.
Below is a table of how the data looks.
Below is how I would like the data to look
Try this simple code,
Sub splitRange()
Dim i As Long, j As Long, k As Long
Cells(1, 6) = Cells(1, 1)
Cells(1, 7) = Cells(1, 2)
j = 1
k = 6
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) = Cells(i - 1, 1) Then
j = j + 1
Cells(j, k) = Cells(i, 1)
Cells(j, k + 1) = Cells(i, 2)
Else
k = k + 3
j = 1
Cells(j, k) = Cells(i, 1)
Cells(j, k + 1) = Cells(i, 2)
End If
Next i
End Sub
Modify the code if you want the output in a separate sheet. I would like you to google it to learn about it.
I had to do something similar. You can try also this code:
Sub Move_Data()
Application.ScreenUpdating = False
Dim r As Integer
Dim StartRow As Integer
Dim EndRow As Integer
Dim ColA As Integer
Dim vLastRow As Integer
Dim vEnd As Integer
r = 1
StartRow = 1
EndRow = 1
ColA = 4
vEnd = 1
vLastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
Do Until Cells(r, 1) <> Cells(StartRow, 1)
DoEvents
r = r + 1
Loop
vEnd = r
Do Until r > vLastRow
DoEvents
StartRow = r
Do Until Cells(r, 1) <> Cells(StartRow, 1)
DoEvents
r = r + 1
Loop
EndRow = r - 1
Range(Cells(StartRow, 1), Cells(EndRow, 2)).Select
Selection.Copy
Cells(1, ColA).Select
ActiveSheet.Paste
ColA = ColA + 3
Loop
r = vEnd + 1
Range(Cells(vEnd, 1), Cells(vLastRow, 2)).ClearContents
Cells(1, 1).Select
Application.ScreenUpdating = True
MsgBox "Done"
End Sub

Fixed Columns to Row

Have data spread across columns
Want to keep the first three columns fixed (columns a, b and c).
And convert columns from four onward into new rows (columns d --> last column where there is a value).
Example:
The colours from columns D -->onwards are NOT always green, blue, black red, etc.... they vary depending on the data loaded in from a power query table.
This is how I want the data to look:
Notice how columns A, B and C are fixed with the same info and only columns D onwards is recreating a new "row".
I've been trying to adapt a VBA script from a previous post on here, but I'm having some complications. I'm also trying to keep it on the sheet that the data is currently on, not create a new sheet. If it is easier to just create a new sheet.. then I can work with that.. Script:
Sub ColumnTorow()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
With ActiveSheet
Dim rRow As Long
rRow = 2
Dim row As Long
row = 2
Dim col As Integer
Do While True
col = 2
Do While True
If data(row, col) = "" Then Exit Do 'Skip Blanks
.Cells(rRow, 1).Value = data(row, 1)
.Cells(rRow, 2).Value = data(row, col)
rRow = rRow + 1
If col = maxCols Then Exit Do 'Exit clause
col = col + 1
Loop
If row = maxRows Then Exit Do 'exit cluase
row = row + 1
Loop
End With
End Sub
This is just an example code that I was provided with and I'm trying to modify... It might not even be the correct solution to this problem but figured I would post it anyways.
Here you go, since I did this yesterday, I got it together fairly quickly:
Sub ColumnToRow()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
Dim newSht As Worksheet
Set newSht = Sheets.Add
With newSht
.Cells(1, 1).Value = data(1, 1)
.Cells(1, 2).Value = data(1, 2)
.Cells(1, 3).Value = data(1, 3)
.Cells(1, 4).Value = data(1, 4)
Dim writeColumn As Double
writeColumn = 1
Dim writeRow As Double
writeRow = 2
Dim row As Double
row = 2
Do
writeColumn = 1
Dim col As Double
col = 4
Do While True
If data(row, col) <> "" Then
Dim firstColData As String
firstColData = data(row, 1)
.Cells(writeRow, writeColumn) = firstColData
writeColumn = 2
Dim secondColData As String
secondColData = data(row, 2)
.Cells(writeRow, writeColumn) = secondColData
writeColumn = 3
Dim thirdColData As String
thirdColData = data(row, 3)
.Cells(writeRow, writeColumn) = thirdColData
writeColumn = 4
.Cells(writeRow, writeColumn).Value = data(row, col)
writeColumn = 1
writeRow = writeRow + 1
End If
If col = maxCols Then
Exit Do 'Exit clause
End If
col = col + 1
Loop
If row = maxRows Then
Exit Do 'exit cluase
End If
row = row + 1
Loop While True
End With
End Sub
consider this code.
Sub TransData()
Dim vDB, vR()
Dim n As Long, i As Long, j As Integer, k As Integer
vDB = Range("a1").CurrentRegion
For i = 2 To UBound(vDB, 1)
For j = 4 To UBound(vDB, 2)
If vDB(i, j) <> "" Then
n = n + 1
ReDim Preserve vR(1 To 4, 1 To n)
For k = 1 To 3
vR(k, n) = vDB(i, k)
Next k
vR(4, n) = vDB(i, j)
End If
Next j
Next i
Sheets.Add
Range("a1").Resize(1, 4) = Array("Item", "Amount", "Price", "Color")
Range("a2").Resize(n, 4) = WorksheetFunction.Transpose(vR)
End Sub

VBA: How to transform a one column full dictionary into one column per letter?

I have a full dictionary. All the words (360 000) are in one column.
I'd like to have Column B with all words starting with "a", column C with all words starting with b...
I am trying to do a loop or something... but... It is just too long.
Any tips? Or did someone already do this vba macro?
Tks,
Stéphane.
If we start with:
Running this short macro:
Sub SeparateData()
Dim N As Long, i As Long, NewCol As Long
Dim M As Long
N = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To N
NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63
If Cells(1, NewCol).Value = "" Then
M = 1
Else
M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1
End If
Cells(M, NewCol).Value = Cells(i, 1).Value
Next i
End Sub
will produce:
NOTE:
You may want to add some error capture logic to the NewCol calculation line.
EDIT#1:
This version may be slightly faster:
Sub SeparateDataFaster()
Dim N As Long, i As Long, NewCol As Long
Dim M As Long, time1 As Date, time2 As Date
N = Cells(Rows.Count, 1).End(xlUp).Row
time1 = Now
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 1 To N
NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63
If Cells(1, NewCol).Value = "" Then
M = 1
Else
M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1
End If
Cells(M, NewCol).Value = Cells(i, 1).Value
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
time2 = Now
MsgBox time1 & vbCrLf & time2
End Sub
You can try something like this.
For 360k records its take about 20sec.
To create tests data i use this sub:
Sub FillTestData()
Dim t As Long
Dim lng As Integer
Dim text As String
'Start = Timer
For t = 1 To 360000
text = vbNullString
lng = 5 * Rnd + 10
For i = 1 To lng
Randomize
text = text & Chr(Int((26 * Rnd) + 65))
Next i
Cells(t, 1) = text
Next t
'Debug.Print Timer - Start
End Sub
And for separate:
Sub sep()
'Start = Timer
Dim ArrWords() As Variant
Dim Row_ As Long
LastRow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
ArrWords = Range("A1:A" & LastRow) 'all data from column A to array
For i = 65 To 90 ' from A to Z
Row_ = 1
For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
If Asc(UCase(ArrWords(j, 1))) = i Then
Cells(Row_, i - 63) = ArrWords(j, 1)
Row_ = Row_ + 1
End If
Next j
Next i
'other than a[A]-z[Z]
Row_ = 1
For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
If Asc(UCase(ArrWords(j, 1))) < 65 Or Asc(UCase(ArrWords(j, 1))) > 90 Then
Cells(Row_, 28) = ArrWords(j, 1)
Row_ = Row_ + 1
End If
Next j
'Debug.Print Timer - Start
End Sub
You could try:
For i = 1 To Cells(Rows.count, 1).End(xlUp).Row
Range(UCase(Left$(Cells(i, 1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Offset(IIf(Range(UCase(Left$(Cells(i, _
1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Row = 1, 0, 1), 0).Value = Cells(i, 1).Text
Next i
Which is just building the destination address using the first letter of the word by doing the following:
Loop through each cell in column A
Get the first letter of that cell and convert it to upper case
Find the last cell in the column starting with that letter
Move over 1 column to the right
Go up until we hit the last row of data
If the last row isn't row 1, move down another row (next blank cell)
Give this cell the same value as the cell in column A that we're assessing
You can enter the following formula:
For letter A in B Column:
=IF(UPPER(LEFT(A1,1))="A",A1,"")
For letter B in C Column:
=IF(UPPER(LEFT(A1,1))="B",A1,"")
Repeat the same for letter C, D and so on..

How can i find a number after character in VBA?

How can I find a numeric number in the same cell after character. For ex After J* find number 01. I will have few rows and inside row some value will J*01 or J*08 im trying separate between character and number using instar in VBA:
Sub zz()
Dim ii As Long, z As Integer, xlastrow As Long
Dim yy As String
xlastrow = Worksheets("Sheet1").UsedRange.Rows.Count
For ii = 1 To xlastrow
yy = "J*"
z = 1
If IsNumeric(Worksheets("Sheet1").Range("B" & ii)) Then
This line separating number after J* character and pasting it to sheet2
Seprate.Find.Range("B" & ii, yy).Value = Worksheet("Sheet2").Range("A" & z)
End If
z = z + 1
Next ii
End Sub
Please try this code
' paste the values in column A.
q1w2e3r4asJ*66bvft654
1234BA
BA1234BA
xuz12354
''''' Code
Option Explicit
Sub Remove_Charecter()
Dim Last_Row As Double
Dim num As Double
Dim i As Integer
Dim j As Integer
Last_Row = Range("A65536").End(xlUp).Row
For i = 1 To Last_Row
num = 0
For j = 1 To Len(Cells(i, 1))
If IsNumeric(Mid(Cells(i, 1), j, 1)) Then
num = Trim(num & Mid(Cells(i, 1), j, 1))
End If
Next j
Cells(i, 2).Value = (num)
Next i
'MsgBox num
End Sub
'--- Output will be
123466654
1234
1234
12354
Try the below piece of codes.
Assumption
Your data that you need to separate is in Column A
There is no blank cells in your data
Trim value will be displayed in the adjacent column i.e. Column B in subsequent cells
Code :
Dim LRow As Double
Dim i As Integer
Dim j As Integer
Dim LPosition As Integer
Dim Number As Double
LRow = Range("A1").End(xlDown).Row
For i = 1 To LRow
Number = 0
LPosition = InStr(1, Cells(i, 1), "J*")
For j = (LPosition + 2) To Len(Cells(i, 1))
If IsNumeric(Mid(Cells(i, 1), j, 1)) Then
num = Trim(num & Mid(Cells(i, 1), j, 1))
End If
Next j
Cells(i, 2).Value = Number
Next i