I have data like this in excel, Column Animal No and Clinical Signs have text data seperated by comma.
Input
i wanted to get the output like this i dont want to use power pivot as the results will be pasted as query table. I want vba code to do the same and paste it in the same sheet
Try,
Sub test()
Dim Ws As Worksheet
Dim vDB As Variant
Dim vR() As Variant
Dim a As Variant, b As Variant
Dim i As Long, n As Long, r As Long
Dim j As Integer, k As Integer
Set Ws = Sheets(1)
vDB = Ws.Range("a1").CurrentRegion
r = UBound(vDB, 1)
For i = 2 To r
a = Split(vDB(i, 2), ",")
b = Split(vDB(i, 4), ",")
For j = 0 To UBound(a)
For k = 0 To UBound(b)
n = n + 1
ReDim Preserve vR(1 To 5, 1 To n)
vR(1, n) = vDB(i, 1)
vR(2, n) = Trim(a(j))
vR(3, n) = vDB(i, 3)
vR(4, n) = Trim(b(k))
vR(5, n) = vDB(i, 5)
Next k
Next j
Next i
With Ws
.Range("a2").Resize(n, 5) = WorksheetFunction.Transpose(vR)
End With
End Sub
Related
I have the following table:
Our main category is fruit/vegetable, its subcategory is their type and the subcategory of their type is the color. For hours I am trying to achieve to following output with a formula, but without success..
The main product type should not duplicate itself in the row. If there are duplicates within the "fruit/vegetable type" we need to take the type only once and all of its colors. Sorry if the explanation is not good. Here is it graphically:
This is a solution using a dictionary.
Sub test()
Dim vDB, vR()
Dim Dic As Object 'Dictionary
Dim Fruit As Object 'Dictionary
Dim Ws As Worksheet, toWs As Worksheet
Dim i As Long, j As Long, r As Long
Dim k As Integer
Set Ws = Sheets(1) 'set your data Sheet
Set toWs = Sheets(2) 'set your result Sheet
vDB = Ws.Range("a1").CurrentRegion
Set Dic = CreateObject("Scripting.Dictionary")
Set Fruit = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(vDB, 1)
If Dic.Exists(vDB(i, 1)) Then
Else
Dic.Add vDB(i, 1), vDB(i, 1)
End If
Next i
r = Dic.Count
ReDim vR(1 To r, 1 To 1000)
For i = 1 To r
vR(i, 1) = Dic.Items(i - 1)
k = 1
For j = 2 To UBound(vDB, 1)
If vDB(j, 1) = Dic.Items(i - 1) Then
If Fruit.Exists(vDB(j, 2)) Then
k = k + 1
vR(i, k) = vDB(j, 3)
Else
Fruit.Add vDB(j, 2), vDB(j, 2)
k = k + 2
vR(i, k - 1) = vDB(j, 2)
vR(i, k) = vDB(j, 3)
End If
End If
Next j
Next i
With toWs
.Range("a1").CurrentRegion.Clear
.Range("a1").Resize(r, 1000) = vR
End With
End Sub
I have a fairly complicated matrix that I'm attempting to create a report tab for.
The code below returns a type mismatch error for For i = 4 To UBound(vDB, 1).
I created a simplified version, which you can access using the link below.
https://drive.google.com/open?id=1awHkMyHrh4uirhmo1T1DU10K9ckDCwE7
Here's the idea:
When a name is entered in the field on the second sheet, the matching name is located in the first column of first sheet.
The information (training name, number, version) for the incomplete trainings (those with an 'N' in the row with the matching name) is copied to the second tab with a transposed layout.
Sub test()
Dim Ws As Worksheet
Dim toWs As Worksheet
Dim vDB, vR()
Dim i As Long, j As Integer
Dim n As Integer
Dim sName As String
Set Ws = Sheets("Sheet1")
Set toWs = Sheets("Sheet2")
vDB = Ws.Range("b3").CurrentRegion
With toWs
sName = .Range("c2")
For i = 4 To UBound(vDB, 1)
If vDB(i, 1) = sName Then
For j = 3 To 5
If vDB(i, j) = "N" Then
n = n + 1
ReDim Preserve vR(1 To 4, 1 To n)
vR(1, n) = vDB(1, j)
vR(2, n) = vDB(2, j)
vR(3, n) = vDB(3, j)
vR(4, n) = vDB(i, j)
End If
Next j
End If
Next i
If n > 0 Then
With .Range("b4")
.CurrentRegion.Clear
.Resize(n, 4) = WorksheetFunction.Transpose(vR)
With .CurrentRegion
.Borders.LineStyle = xlContinuous
.CurrentRegion.BorderAround Weight:=xlMedium
.HorizontalAlignment = xlCenter
End With
.Resize(n, 3).Interior.Color = 14277081
.Resize(n, 3).BorderAround Weight:=xlMedium
End With
Else
.Range("a4").CurrentRegion.Clear
MsgBox "No Data"
End If
End With
End Sub
I'm very new to VBA.
I'm very new to VBA and I have a fairly complicated matrix that I'm attempting to create a search tab for. Please help!
I've created a simplified version, which you can access using the link below.
https://drive.google.com/open?id=1awHkMyHrh4uirhmo1T1DU10K9ckDCwE7
Here's the idea:
When a name is entered in the field on the second sheet, the matching
name is located in the first column of first sheet.
The information (training name, number, version) for the incomplete trainings
(those with an 'N' in the row with the matching name) is copied to
the second tab with a transposed layout.
Thank you!
Try
Sub test()
Dim Ws As Worksheet
Dim toWs As Worksheet
Dim vDB, vR()
Dim i As Long, j As Integer
Dim n As Integer
Dim sName As String
Set Ws = Sheets("Sheet1")
Set toWs = Sheets("Sheet2")
vDB = Ws.Range("b3").CurrentRegion
With toWs
sName = .Range("c2")
For i = 4 To UBound(vDB, 1)
If vDB(i, 1) = sName Then
For j = 3 To 5
If vDB(i, j) = "N" Then
n = n + 1
ReDim Preserve vR(1 To 4, 1 To n)
vR(1, n) = vDB(1, j)
vR(2, n) = vDB(2, j)
vR(3, n) = vDB(3, j)
vR(4, n) = vDB(i, j)
End If
Next j
End If
Next i
If n > 0 Then
With .Range("b4")
.CurrentRegion.Clear
.Resize(n, 4) = WorksheetFunction.Transpose(vR)
With .CurrentRegion
.Borders.LineStyle = xlContinuous
.CurrentRegion.BorderAround Weight:=xlMedium
.HorizontalAlignment = xlCenter
End With
.Resize(n, 3).Interior.Color = 14277081
.Resize(n, 3).BorderAround Weight:=xlMedium
End With
Else
.Range("a4").CurrentRegion.Clear
MsgBox "No Data"
End If
End With
End Sub
I have this sheet.
In VBA I get the contents of row 8 column AV, AU, AW, like this.
.Cells(row_level - 1, col_comment)
Row 7 is a merged cell. I would like to get the contents of AV if the column is AV, AU, or AW. The tricky part is that there aren't always three merged columns. There might be anywhere from 2 to 7.
try,
Sub test()
Dim rngDB As Range, rng As Range
Dim vR()
Dim i As Long, n As Long, j As Integer
Set rngDB = Range("au8", Range("au" & Rows.Count).End(xlUp))
For Each rng In rngDB
If rng.MergeCells Then
If rng.Address = rng.MergeArea.Range("a1").Address Then
n = n + 1
ReDim Preserve vR(1 To 3, 1 To n)
For j = 1 To 3
vR(j, n) = rng(1, j)
Next j
End If
Else
n = n + 1
ReDim Preserve vR(1 To 3, 1 To n)
For j = 1 To 3
vR(j, n) = rng(1, j)
Next j
End If
Next rng
Sheets.Add
Range("a1").Resize(n, 3) = WorksheetFunction.Transpose(vR)
End Sub
Column A contains the labels or outcome value, Columns B-N contain varying lengths of comma separated values, but range for each column is the same (i.e., 1-64). The goal is to covert to a new table with Column A representing the value range (1-64) and Columns B-N the labels/outcome from the original table.
A semi-related solution was sought here, but without use of macros.
I will let you to modify this code,
Sub splitThem()
Dim i As Long, j As Long, k As Long, x As Long
x = 1
Sheets.Add.Name = "newsheet"
For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, 2).End(xlUp).Row
If Cells(i, j) <> "" Then
For k = 1 To Len(Cells(i, j)) - Len(Replace(Cells(i, j), ",", "")) + 1
Sheets("newsheet").Cells(x, j) = Cells(i, 1)
x = x + 1
Next k
End If
Next i
x = 1
Next j
End Sub
Try this code.
Sub test()
Dim vDB, vR()
Dim vSplit, v As Variant
Dim Ws As Worksheet
Dim i As Long, n As Long, j As Integer, c As Integer
vDB = Range("a2").CurrentRegion
n = UBound(vDB, 1)
c = UBound(vDB, 2)
ReDim vR(1 To 64, 1 To c)
For i = 1 To 64
vR(i, 1) = i
Next i
For i = 2 To n
For j = 2 To c
vSplit = Split(vDB(i, j), ",")
For Each v In vSplit
vR(v, j) = vDB(i, 1)
Next v
Next j
Next i
Set Ws = Sheets.Add '<~~ replace your sheet : Sheets(2)
With Ws
For i = 1 To c
.Range("b1")(1, i) = "COND" & i
Next i
.Range("a2").Resize(64, c) = vR
End With
End Sub