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
Related
The code I have takes cells containing the delimiter (; ) from a column, and creates new rows (everything except the column is duplicated) to separate those values.
What I have
I need this for multiple columns in my data, but I don't want the data to overlap (ex: for 3 columns, I want there to be only one value per row in those 3 columns). It would be ideal if I could select multiple columns instead of only one as my code does now.
What I want
Sub splitByCol()
Dim r As Range, i As Long, ar
Set r = Worksheets("Sheet").Range("J2000").End(xlUp)
Do While r.Row > 1
ar = Split(r.Value, "; ")
If UBound(ar) >= 0 Then r.Value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).Value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
Try this code
Sub Test()
Dim a, x, e, i As Long, ii As Long, iii As Long, k As Long
a = Range("A1").CurrentRegion.Value
ReDim b(1 To 1000, 1 To UBound(a, 2))
For i = LBound(a) To UBound(a)
For ii = 2 To 3
x = Split(a(i, ii), "; ")
For Each e In x
k = k + 1
b(k, 1) = k
b(k, 2) = IIf(ii = 2, e, Empty)
b(k, 3) = IIf(ii = 3, e, Empty)
b(k, 4) = a(i, 4)
Next e
Next ii
Next i
Range("A5").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
I'd go this way
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
With .Cells(.Rows.Count, "C").End(xlUp).Offset(1, -1)
With .Resize(UBound(currFirstColValues) + 1)
.Value = currFirstColValues
.Offset(, 2).Value = thirdColValues(iRow, 1)
End With
End With
With .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 1)
With .Resize(UBound(currSecondColValues) + 1)
.Value = currSecondColValues
.Offset(, 1).Value = thirdColValues(iRow, 1)
End With
End With
Next
End With
End Sub
Follow the code step by step by pressing F8 while the cursor is in any code line in the VBA IDE and watch what happens in the Excel user interface
EDIT
adding edited code for a more "parametric" handling by means of a helper function
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
WriteOne .Cells(.Rows.Count, "C").End(xlUp).Offset(1), _
currFirstColValues, thirdColValues(iRow, 1), _
-1, 2
WriteOne .Cells(.Rows.Count, "B").End(xlUp).Offset(1), _
currSecondColValues, thirdColValues(iRow, 1), _
1, 1
Next
End With
End Sub
Sub WriteOne(refCel As Range, _
currMainColValues As Variant, thirdColValue As Variant, _
mainValuesOffsetFromRefCel As Long, thirdColValuesOffsetFromRefCel As Long)
With refCel.Offset(, mainValuesOffsetFromRefCel)
With .Resize(UBound(currMainColValues) + 1)
.Value = currMainColValues
.Offset(, thirdColValuesOffsetFromRefCel).Value = thirdColValue
End With
End With
End Sub
Please, use the next code. It uses arrays and should be very fast for big ranges to be processed, working mostly in memory:
Sub testSplitInsert()
Dim sh As Worksheet, lastR As Long, arr, arrSp, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
arr = sh.Range("B1:D" & lastR).Value
ReDim arrFin(1 To UBound(arr) * 10, 1 To 3) 'maximum to keep max 10 rows per each case
k = 1 'initialize the variable to load the final array
For i = 1 To UBound(arr)
arrSp = Split(Replace(arr(i, 1)," ",""), ";") 'trim for the case when somebody used Red;Blue, instead of Red; Blue
For j = 0 To UBound(arrSp)
arrFin(k, 1) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
Next j
arrSp = Split(Replace(arr(i, 1)," ",""), ";")
For j = 0 To UBound(arrSp)
arrFin(k, 2) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
Next j
Next
sh.Range("G1").Resize(k - 1, 3).Value = arrFin
End Sub
It processes the range in columns "B:D" and returns the result in columns "G:I". It can be easily adapted to process any columns range and return even overwriting the existing range, but this should be done only after checking that it return what you need...
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 have a very big excel file and i want to transfer all information from worksheet to the variant variable.
I don't need all the rows from the file, so I want to chose rows that I am interested in.
I have tried to make complex Range variable using Union to select rows that i am interested in.
The problem is that my program doesn't increase range if useful inormation is divided by the not wanted rows.
example:
I have got table like this:
123|1|1|1
123|2|2|2
456|3|3|3
123|4|4|4
I want rows with 123 in the first column, but then i am using Union function, I got only first two rows, but not the fourth.
I need:
123|1|1|1
123|2|2|2
123|4|4|4
but recieve:
123|1|1|1
123|2|2|2
Below will be a part of my code. This part is in the cycle
r - Range
WS - Worksheet
Set r = WS.Range("A1:A1")
Can somebody help me with this. I am looking for a solution for hour already.
If WS.Cells(i, 1).Value = "123" Then
If r.Columns.Count() < 2 Then
Set r = WS.Range(WS.Cells(i, 1), WS.Cells(i, 4))
Else
Set r = Union(r, WS.Range(WS.Cells(i, 1), WS.Cells(i, 4)))
End If
End If
This works, using your approach:
Sub x()
Dim r As Range, ws As Worksheet, i As Long
Dim j As Long
Set ws = ActiveSheet
Set r = ws.Range("A1")
For i = 1 To 4
If ws.Cells(i, 1).Value = 123 Then
If r.Columns.Count < 2 Then
Set r = ws.Range(ws.Cells(i, 1), ws.Cells(i, 4))
Else
Set r = Union(r, ws.Range(ws.Cells(i, 1), ws.Cells(i, 4)))
End If
End If
Next i
For j = 1 To r.Areas.Count
Range("G" & Rows.Count).End(xlUp)(2).Resize(r.Areas(j).Rows.Count, r.Areas(j).Columns.Count).Value = r.Areas(j).Value
Next j
End Sub
Using an array approach, the results are stored in v2.
Sub x()
Dim ws As Worksheet, i As Long, j As Long, v As Variant, v2() As Variant
v = Range("A1:D4").Value
ReDim Preserve v2(1 To UBound(v, 1), 1 To UBound(v, 2))
For i = LBound(v, 1) To UBound(v, 1)
If v(i, 1) = 123 Then
j = j + 1
v2(j, 1) = v(i, 1)
v2(j, 2) = v(i, 2)
v2(j, 3) = v(i, 3)
v2(j, 4) = v(i, 4)
End If
Next i
Range("G1").Resize(j, UBound(v2, 2)).Value = v2
End Sub
I need to do the following:
I have a table where the 13th column contains strings such as
acbd,ef,xyz
qwe,rtyu,tqyuiop
And what I want to create new rows in order to separate those values:
acbd
ef
xyz
qwe
rtyu
tqyuiop
Meaning I would have now 6 rows instead of 2, and all the other information on cells would remain the same (i.e. all the other values of the row would repeat themselves through all the new rows).
What I have tried is the following:
Sub test()
Dim coma As Integer
Dim finalString As String
Set sh = ActiveSheet
For Each rw In sh.Rows
* If find a coma, then copy the row, insert a new row, and paste in this new row*
If InStr(1, sh.Cells(rw.Row, 13).Value, ",") Then
Rows(rw.Row).Copy
Rows(rw.Row).insert shift:=xlShiftDown
Rows(rw.Row).PasteSpecial xlPasteValues
* Now it will look for the position of the comma and assign
to finalString what's before the comma, and assign to mod String
what's after the comma *
coma = InStr(1, sh.Cells(rw.Row, 13).Value, ",")
finalString = Left(sh.Cells(rw.Row, 13).Value, coma - 1)
modString = Right(sh.Cells(rw.Row, 13).Value, Len(sh.Cells(rw.Row, 13).Value) - coma)
* Replace the values: *
sh.Cells(rw.Row, 13).Value = modString
sh.Cells(rw.Row - 1, 13).Value = finalString
End If
Next rw
MsgBox ("End")
End Sub
This code works perfectly well except that for tables with 400 rows it takes 15 +-5 seconds to be completed.
I would like some suggestions on how to improve the performance of this. Thank you!
With data in column L, give this a try:
Sub LongList()
Dim wf As WorksheetFunction, arr, s As String
Set wf = Application.WorksheetFunction
s = wf.TextJoin(",", True, Range("L:L"))
arr = Split(s, ",")
Range("M1").Resize(UBound(arr) + 1, 1).Value = wf.Transpose(arr)
End Sub
Note:
No looping over cells.No looping within cells. This process can be accomplished with just worksheet formulas, VBA is not needed.
Try this.
Sub test()
Dim vDB, vR(), vS, s
Dim i As Long, j As Integer, n As Long
vDB = Range("a1").CurrentRegion
For i = 1 To UBound(vDB, 1)
vS = Split(vDB(i, 13), ",")
For Each s In vS
n = n + 1
ReDim Preserve vR(1 To 13, 1 To n)
For j = 1 To 12
vR(j, n) = vDB(i, j)
Next j
vR(13, n) = s
Next s
Next i
Range("a1").Resize(n, 13) = WorksheetFunction.Transpose(vR)
End Sub
Before.
After.
If you have more columns, do like this.
Sub test()
Dim vDB, vR(), vS, s
Dim i As Long, j As Integer, n As Long
Dim c As Integer
vDB = Range("a1").CurrentRegion
c = UBound(vDB, 2)
For i = 1 To UBound(vDB, 1)
vS = Split(vDB(i, 13), ",")
For Each s In vS
n = n + 1
ReDim Preserve vR(1 To c, 1 To n)
For j = 1 To c
vR(j, n) = vDB(i, j)
Next j
vR(13, n) = s
Next s
Next i
Range("a1").Resize(n, c) = WorksheetFunction.Transpose(vR)
End Sub
If you want an immediate boost in performance without having to adjust any kind of code just add Application events at the beginning...
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
and be sure to turn them back on at the end of the code...
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
These two simple statements usually speed up code considerably.
This should look for comma-delimited values in column M and overwrite the values in column M with the split values (basically what your code was doing).
Option Explicit
Sub splitValues()
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
With sourceSheet
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "M").End(xlUp).Row
Dim inputValues() As Variant
inputValues = .Range("M1:M" & lastRow).Value2
Dim splitString() As String
Dim rowIndex As Long
Dim outputArray As Variant
Dim outputRowIndex As Long
outputRowIndex = 1
For rowIndex = LBound(inputValues, 1) To UBound(inputValues, 1)
splitString = VBA.Strings.Split(inputValues(rowIndex, 1), ",", -1, vbBinaryCompare)
outputArray = Application.Transpose(splitString)
.Cells(outputRowIndex, "M").Resize(UBound(outputArray, 1), UBound(outputArray, 2)).Value2 = outputArray
outputRowIndex = outputRowIndex + UBound(outputArray, 1)
Next rowIndex
End With
End Sub
I have a 10k+ lines Excel file, that is structured as follows: (in column A): "Name of City is:" followed by a few rows starting with
"contribution from..." followed by
lines of no interest... followed by
"END OF CASE"... and repeat.
I need to extract the rows starting with "Name of City" and the "contribution from" rows that follows the Name of City, and paste each group of rows in a separate sheet. Can you help? Thanks eternally.
I don't know , I understand your problem.
Sub transData()
Dim vDB, vR()
Dim i As Long, n As Long
vDB = ActiveSheet.UsedRange
For i = 1 To UBound(vDB, 1)
If Left(vDB(i, 1), 4) = "Name" Then
n = n + 1
ReDim Preserve vR(1 To n)
End If
vR(n) = vR(n) & " " & vDB(i, 1)
Next i
Sheets.Add
Range("a1").Resize(n) = WorksheetFunction.Transpose(vR)
End Sub
Or,
Sub transData()
Dim vDB, vR()
Dim i As Long, n As Long
vDB = ActiveSheet.UsedRange
For i = 1 To UBound(vDB, 1)
If Left(vDB(i, 1), 4) = "Name" Then
n = n + 1
ReDim Preserve vR(1 To n)
End If
If Left(vDB(i, 1), 4) = "Name" Or Left(vDB(i, 1), 12) = "contribution" Then
vR(n) = vR(n) & " " & vDB(i, 1)
End If
Next i
Sheets.Add
Range("a1").Resize(n) = WorksheetFunction.Transpose(vR)
End Sub