I have an excel table where there are part codes in a column and for every part code, there are 3-4 subsections (1100-1400) with information which I need to attach to the part code in a column view.
The number of created rows depends on if there is data entered into subsection 1400. 1100-1300 has always information and needs to be converted into a table.
I don't even know from where to start so currently I have no code to show
I added a picture of how the data is represented and what the result should look like:
You could do it like that
Option Explicit
Sub TransformA()
Dim rg As Range
Dim lastRow As Long, lineNo As Long, i As Long, j As Long
Dim shInput As Worksheet, shResult As Worksheet
Dim vDat As Variant, resDat As Variant
Dim subSection As String
' Make sure you run the code with the data in the Activesheet
Set shInput = ActiveSheet
' And you have data which starts in row 4 with the heading in row 3
' otherwise adjust accordingly
lastRow = shInput.Range("A4").End(xlDown).Row
Set rg = shInput.Range("A4:I" & lastRow)
vDat = rg
ReDim resDat(1 To UBound(vDat, 1) * 4, 1 To 4)
lineNo = 1
For j = 1 To UBound(vDat, 1)
For i = 0 To 2
Select Case i
Case 0: subSection = "1100"
Case 1: subSection = "1200"
Case 2: subSection = "1300"
End Select
resDat(lineNo + i, 1) = vDat(j, 1)
resDat(lineNo + i, 2) = subSection
resDat(lineNo + i, 3) = vDat(j, 2 + 2 * i)
resDat(lineNo + i, 4) = vDat(j, 3 + 2 * i)
Next
i = 3
subSection = "1400"
If Len(vDat(j, 2 + 2 * i)) = 0 And Len(vDat(j, 3 + 2 * i)) = 0 Then
lineNo = lineNo + 3
Else
resDat(lineNo + i, 1) = vDat(j, 1)
resDat(lineNo + i, 2) = subSection
resDat(lineNo + i, 3) = vDat(j, 2 + 2 * i)
resDat(lineNo + i, 4) = vDat(j, 3 + 2 * i)
lineNo = lineNo + 4
End If
Next
' Output the result to a new sheet
Set shResult = Sheets.Add
With shResult
.Cells(1, 1).Value = "Part Code"
.Cells(1, 2).Value = "Subsection"
.Cells(1, 3).Value = "Time"
.Cells(1, 4).Value = "Text"
End With
shResult.Range("A2").Resize(UBound(resDat, 1), 4) = resDat
End Sub
Related
In Excel 365, I have data in this format:
Or, in text:
1,2,3,7 A
4 B
5 C
6, 8 D
And I'm trying to split the data so it becomes this:
Or, in text
1 A
2 A
3 A
4 B
5 C
6 D
7 A
8 D
The leftmost row is always composed by numbers separated by comma or a single number. The right row can be any data.
The following VBA code will do most of what you want:
Sub ExpandRows()
Dim R As Range
Dim Rw As Range
Dim I As Integer
Dim J As Integer
Dim K As Integer
Dim S As String
Dim Tokens(1 To 1000) As String
Dim NTokens As Integer
Const Delim As String = ","
Dim StartSize As Integer
Dim TopCell As Range
Dim BotCell As Range
Set R = Selection
Set TopCell = R.Cells(1, 1)
Set BotCell = R.Cells(R.Rows.Count, 1)
StartSize = R.Rows.Count
For I = StartSize To 1 Step -1
S = R(I, 1)
If (S <> "") Then
J = 0
NTokens = 0
Do
K = InStr(J + 1, S, Delim)
If (K = 0) Then
NTokens = NTokens + 1
Tokens(NTokens) = Mid$(S, J + 1, Len(S) - J)
Else
NTokens = NTokens + 1
Tokens(NTokens) = Mid$(S, J + 1, (K - J - 1))
J = K
End If
Loop Until (K = 0)
End If
If (NTokens > 1) Then
For J = NTokens To 2 Step -1
If (Tokens(J) <> "") Then
Set Rw = R.Cells(I, 1).EntireRow
Call Rw.Select
Call Rw.Copy
Call R.Cells(I + 1, 1).EntireRow.Select
Call Rw.Insert(xlDown)
If (I = 1) Then
Set TopCell = TopCell.Cells(0, 1)
Set R = Range(TopCell, BotCell)
End If
Call R.Select
Call R.Cells(I + 1, 1).Select
R(I + 1, 1) = Tokens(J)
End If
Next J
R(I, 1) = Tokens(1)
End If
Next I
End Sub
This code will split the cells and create new rows with a single entry.
To use it, select the first column and execute the method.
After that, all you have to do is sort on the first column.
I have a worksheet with over 60,000 rows and two columns. One column is transaction id, the other is item. I want to find the combinations of items in the orders. I found this vba code from someone with a similar problem
Sub basket()
On Error Resume Next
Dim ps(2, 20)
r = 3
tr = Cells(2, 1)
Item = Cells(2, 2) + "."
ps(1, 1) = 1
ps(2, 1) = Len(Item)
r2 = 2
r3 = 3
ic = 2
While Cells(r, 1) <> ""
If Cells(r, 1) <> tr Then
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
Item = ""
ic = 1
tr = Cells(r, 1)
End If
ps(1, ic) = Len(Item) + 1
ps(2, ic) = Len(Cells(r, 2)) + 1
Item = Item + Cells(r, 2) + "."
r = r + 1
ic = ic + 1
Wend
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
End Sub
Which worked when I ran the exact same code but with item categories. The problem is I'm running it with the item names and it's always crashing my Excel. Is there anyone that can guide me in the right direction?
this is the worksheet that doesn't work
this is what I get when I run it with the item category which works. They're the exact same data, one just has it as item category, and the other is item name.
Your code sample didn't do anything for me. It ran, but it didn't actually produce any kind of results at all. I did a quick Google search and found this.
Sub ListCombinations()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Set sht = ActiveSheet
'lists begin in A1, B1, C1, D1
For Each c In sht.Range("A2:B2").Cells
col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
numCols = numCols + 1
Next c
res = Combine(col, "~~")
For i = 0 To UBound(res)
arr = Split(res(i), "~~")
sht.Range("H1").Offset(i, 0).Resize(1, numCols) = arr
Next i
End Sub
'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()
Dim rv() As String
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long
Dim numIn As Long, s As String, r As Long
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(0 To t - 1) 'resize destination array
For n = 0 To (t - 1)
s = ""
For i = 1 To numIn
s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
Next i
rv(n) = s
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
Combine = rv
End Function
I found that from this link.
VBA - Write all possible combinations of 4 columns of data
I'm pretty sure if you do some more Googling, you can find other concepts that do pretty much the same thing.
i have some label data to print in columns and rows format based on the user defined input Value. their are 3 main inputs based conditions:
1) No of starting label to skip 2) No of label per Row 3) No of Rows Per page
I have one data sheet which has data in column A and No of copies to be printed in column B. i am attaching examples images with different input and output in page i expect to be printed. Also giving link to code which could be relevant for my purpose.
Data Sheet
Print Sheet
My codes are limited to 3 columns with unlimited rows and without skip
Here Can you tweak these codes for Userform : Make it small and efficient are codes for dynamic userfrom textbox creation given by #Brian M Stafford but not sure how to implement for this purpose
Public Sub GenerateLabels()
Dim CopyRowValue As String
Dim SecondDataCol, ThirdDataCol, FirstDataCol As Long
Dim SecondDataRow, ThirdDataRow, FirstDataRow As Long
Set shdata = ThisWorkbook.Sheets("Database")
Set shgenerate = ThisWorkbook.Sheets("LabelGenerate")
Set shDesignFormat = ThisWorkbook.Sheets("LabelDesignFormatBeforePrint")
FirstDataCol = shgenerate.Cells(1, shgenerate.Columns.Count).End(xlToLeft).Column
SecondDataCol = shgenerate.Cells(1, shgenerate.Columns.Count).End(xlToLeft).Column
ThirdDataCol = shgenerate.Cells(1, shgenerate.Columns.Count).End(xlToLeft).Column
FirstDataRow = shgenerate.Cells(shgenerate.Rows.Count, "A").End(xlUp).Row
SecondDataRow = shgenerate.Cells(shgenerate.Rows.Count, "C").End(xlUp).Row
ThirdDataRow = shgenerate.Cells(shgenerate.Rows.Count, "E").End(xlUp).Row
'======== Copy From Data Sheet============
Last_Row = Sheets("Database").Range("A" & Rows.Count).End(xlUp).Row
For r = 2 To Last_Row
shdata.Cells(x, "A").Copy
shDesignFormat.Range("B3").Paste 'pasting data to design sheet before print (to format data)
CopyRowValue = Worksheets("Database").Cells(r, "B").value
For r2 = 1 To CopyRowValue
'=====Paste to Generate Sheet ====
'Cells(FirstDataRow + 1, FirstDataCol + 1).Offset(0, 0).Select
If IsEmpty(shgenerate.Cells(FirstDataRow + 0, FirstDataCol + 0).Offset(0, 0).value) = True Then
shDesignFormat.Range("B3").Copy _
Destination:=shgenerate.Cells(FirstDataRow + 0, FirstDataCol + 0).Offset(0, 0)
ElseIf IsEmpty(shgenerate.Cells(SecondDataRow + 0, SecondDataCol + 2).Offset(0, 0).value) = True Then 'offset used to find empty cell if design layout changed
shDesignFormat.Range("B3").Copy _
Destination:=shgenerate.Cells(SecondDataRow + 0, SecondDataCol + 2).Offset(0, 0)
ElseIf IsEmpty(shgenerate.Cells(ThirdDataRow + 0, ThirdDataCol + 4).Offset(0, 0).value) = True Then
shDesignFormat.Range("B3").Copy _
Destination:=shgenerate.Cells(ThirdDataRow + 0, ThirdDataCol + 4).Offset(0, 0)
SecondDataRow = SecondDataRow + 2
ThirdDataRow = ThirdDataRow + 2
FirstDataRow = FirstDataRow + 2
End If
Next r2
Next r
Application.CutCopyMode = False
End Sub
Looking at your code, my first thought was it could be simplified. Once I did this, I began modifying to add needed requirements. The main task was keeping track of the current location. The code ended up like this:
Option Explicit
Public Sub GenerateLabels(ByVal LabelsToSkip As Integer, ByVal LabelsPerRow As Integer, ByVal RowsPerPage As Integer)
Dim shdata As Worksheet
Dim shgenerate As Worksheet
Dim shDesignFormat As Worksheet
Dim curRow As Long
Dim curCol As Long
Dim RowsPerPageCount As Long
Dim r As Long
Dim r2 As Long
Set shdata = ThisWorkbook.Sheets("Database")
Set shgenerate = ThisWorkbook.Sheets("LabelGenerate")
Set shDesignFormat = ThisWorkbook.Sheets("LabelDesignFormatBeforePrint")
shgenerate.UsedRange.ClearContents
curRow = 1
curCol = 1
RowsPerPageCount = 1
For r = 2 To shdata.Range("A" & Rows.Count).End(xlUp).Row
'======== Copy From Data Sheet============
shdata.Cells(r, "A").Copy
shDesignFormat.Range("B3").PasteSpecial 'pasting data to design sheet before print (to format data)
For r2 = 1 To shdata.Cells(r, "B").Value + LabelsToSkip
'=====Paste to Generate Sheet ====
If curCol > LabelsPerRow * 2 Then '* 2 for double spacing
curCol = 1
If RowsPerPage > 0 And (RowsPerPageCount + 1) Mod (RowsPerPage + 1) = 0 Then
curRow = curRow + 10 'new page
RowsPerPageCount = 1
Else
curRow = curRow + 2
RowsPerPageCount = RowsPerPageCount + 1
End If
End If
If r2 > LabelsToSkip Then
LabelsToSkip = 0
shDesignFormat.Range("B3").Copy Destination:=shgenerate.Cells(curRow, curCol)
End If
curCol = curCol + 2
Next r2
Next r
Application.CutCopyMode = False
End Sub
I recommend using Option Explicit and declaring all variables that you need.
i would like to split the cells into TextA, TextB and TextC after "." and sort by the Text genre.
I also tried this:
Sub split_By_Text()
Set sh1 = ThisWorkbook.Sheets(1)
Set sh2 = ThisWorkbook.Sheets(2)
lrow1 = sh1.Range("A65356").End(xlUp).Row
For j = 2 To lrow1
splitVals = Split(sh1.Cells(j, 2), ".")
totalVals = UBound(splitVals)
For i = LBound(splitVals) To UBound(splitVals)
lrow2 = sh2.Range("B65356").End(xlUp).Row
lrow3 = sh2.Range("A65356").End(xlUp).Row
sh2.Cells(lrow3 + 1, 1) = sh1.Cells(j, 1)
'Debug.Print sh1.Cells(j, 1)
sh2.Cells(lrow2 + 1, 2) = splitVals(i)
'Debug.Print splitVals(i)
Next i
Next j
sh2.Activate
sh2.Range("A1") = "Drink ID"
sh2.Range("B1") = "Recipe_data"
sh2.Range("C1") = "Volume"
End Sub
But when i have only one sentence excel also add a line.
THX
Input:
Output:
Rearrange data to be split due to genre
Demonstrate an approach via array assignment and using the advanced restructuring features of the Application.Index() function:
Sub ReArrange()
Const GENRE& = 1, ID& = 2, TXT& = 5, TXTA& = 6, TXTB& = 7, TXTC& = 8 ' columns in variant array v2
With Sheet1 ' source sheet's CodeName (!)
' [0] define data range
Dim v, rng As Range, lastRow&
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:F" & lastRow)
' [1] get data
v = rng
' [2] rearrange array rows & columns (inserting 2 new columns)
v = Application.Index(v, _
Application.Transpose(getRows(v)), _
Array(0, 1, 2, 3, 0, 4, 5, 6))
v(1, GENRE) = "Genre": v(1, TXT) = "Text" ' renew headers
' [3] Fill in genre & tokens
Dim i&, ii&, cnt& ' item counters
Dim a&, b&, c& ' split item boundaries
For i = 2 To UBound(v) ' loop through v2
If v(i, ID) <> v(i - 1, ID) Then
cnt = 0: ii = 0
a = UBound(Split(v(i, TXTA), ".")) ' items TextA
b = UBound(Split(v(i, TXTB), ".")) ' items TextB
c = UBound(Split(v(i, TXTC), ".")) ' items TextC
End If
cnt = cnt + 1: ii = ii + 1 ' increment id and genre counters
Select Case cnt
Case Is <= a: v(i, GENRE) = "A"
v(i, GENRE) = "A": v(i, TXT) = Split(v(i, TXTA), ".")(ii - 1): If ii = a Then ii = 0
Case Is <= a + b
v(i, GENRE) = "B": v(i, TXT) = Split(v(i, TXTB), ".")(ii - 1): If ii = b Then ii = 0
Case Is <= a + b + c
v(i, GENRE) = "C": v(i, TXT) = Split(v(i, TXTC), ".")(ii - 1): If ii = c Then ii = 0
End Select
Next i
End With
' [4] write results back whereever you want (reducing array by 3 temporary columns)
Sheet2.Range("A1").Resize(UBound(v), UBound(v, 2) - 3) = v
End Sub
Helper function getRows()
Function getRows(arr) As Variant()
' Purpose: return an array of n-times repeated row numbers (based on number of splits)
Dim i&, ii&, j&, cnt&
Dim tmp(), tokens
ReDim tmp(0 To UBound(arr) * 10)
tmp(cnt) = 1: cnt = cnt + 1 ' one title row equals row no 1; increment new rows counter
For i = 2 To UBound(arr)
For j = 4 To 6 ' D:F
tokens = Split(arr(i, j), ".") ' upper boundary minus one because of right side point
For ii = LBound(tokens) To UBound(tokens) - 1
tmp(cnt) = i ' input row number as often as necessary
cnt = cnt + 1 ' increment counter
Next ii
Next
Next i
ReDim Preserve tmp(0 To cnt - 1) ' resize array to actual item size
getRows = tmp ' return function result array
'Debug.Print Join(tmp, ",") ' Array(1,2,2,2,3,3,3,3,3,3,3,3,4,4,4,4,4,4,5,5,5,5,5,5,6,6,6,6,6,6)
End Function
In My office five Employee is working for example In my office Employ Entry Exit sheet is dere..
This is Main Sheet
Now my requirement
category wise data copy to this sheet to other sheet but it's do it automatically
Like Example
enter image description here
I hope I am interpreting your question correctly, but please let me know if I have misinterpreted your request.
Try the following code on your sheet:
Sub AutoCopyByName()
Dim Names() As String
Dim i As Long, NumRows As Long, NameRow() As Long
Dim j As Integer, NumNames As Integer
j = 0
NumSites = 0
'''''''''''''''''''''''''''''''''''''''''''
'''COUNT NUMBER OF ROWS WITH INFORMATION'''
'''''''''''''''''''''''''''''''''''''''''''
i = 2 'Standard Counter (counts all non-blank cells)
NumRows = 1 'Number of rows with information
Do While WorksheetFunction.IsText(Sheets("data").Range("A" & i))
If Sheets("data").Range("A" & i) <> " " Then NumRows = NumRows + 1
i = i + 1
Loop
'''''''''''''''''''''''''''
'''COUNT NUMBER OF NAMES'''
'''''''''''''''''''''''''''
For i = 3 To NumRows + 1
If Sheets("data").Cells(i, 1) <> Sheets("data").Cells(i - 1, 1) Then NumNames = NumNames + 1 'Works
Next i
''''''''''''''''''
'''REDIM ARRAYS'''
''''''''''''''''''
ReDim Names(NumNames)
ReDim NameRow(NumNames)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''FINDING THE LOCATION OF EACH NAME IN THE SHEET AND STORING IT IN NameRow ARRAY'''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = 2 To NumRows + 1
If Sheets("data").Cells(i, 1) <> Sheets("data").Cells(i - 1, 1) Then
Names(j) = Sheets("data").Cells(i, 1).Value
NameRow(j) = i
j = j + 1
End If
Next i
'''''''''''''''''''''''''''''''''''''''''
'''COPY ENTRIES PER NAME TO EACH SHEET'''
'''''''''''''''''''''''''''''''''''''''''
For i = 0 To NumNames - 1
Worksheets.Add
Worksheets(1).Name = Names(i)
Worksheets("data").Rows(1).Copy
Worksheets(Names(i)).Paste
Worksheets("data").Activate
Worksheets("data").Range(Cells(NameRow(i), 1), Cells(NameRow(i + 1) - 1, 1)).EntireRow.Copy
Worksheets(Names(i)).Activate
Worksheets(Names(i)).Range("A2").Select
Worksheets(Names(i)).Paste
Next i
End Sub
I've used the following as my input sheet