Assume Column B has data such as Data1/Data2/Data3-1/Data3-7 - all other rows have various data.
I need to take each row that has that Column B (some may not) and create 1 row for each individual value, with every other piece of data in the row copied for all of them.
Data may have symbols, dashes, and other random stuff, but the actual data itself will not have a / in it, only / is used to designate split lines
Any1 know the best way to do this? Excel 07 and OO available.
Is a VBA solution OK?
Sub DuplicateRows()
Dim r As Range
Set r = Cells(Rows.Count, 2).End(xlUp)
Do While r.Row > 1
TestRow r
Set r = r.Offset(-1, 0)
Loop
TestRow r
End Sub
Sub TestRow(r As Range)
Dim i As Long, n As Long
Dim a() As String
i = InStr(r, "/")
If i > 0 Then
n = Len(r) - Len(Replace(r, "/", ""))
r.EntireRow.Copy
r.Offset(1, 0).Resize(n).EntireRow.Insert Shift:=xlDown
a = Split(r, "/")
For i = 0 To n
r.Offset(i, 0) = a(i)
Next
End If
Application.CutCopyMode = False
End Sub
Related
For context of the code here. I have combined several of these 96 cell ranges into one larger range composed on n smaller ranges. Reason for doing this is to make it (more) scalable.
I have a range of data I want to break them up into n ranges/chunks and run my function on each (function below, shout out to #Tim Williams for the function) and combine the outputs all into a column. One solution I don't really like but I could do is to simply run the function on each n chunks/ranges and manually combine them, however, that's not really optimal for what I need. I am still pretty new to VBA, any ideas would be much appreciated!
The function I am using is as follows. Note my comment within the function:
Sub Tester()
Dim rng As Range, arr
Dim Poolws As Worksheet
Dim Combows As Worksheet
Dim plates As Range
Set Poolws = ThisWorkbook.Sheets("Pools")
Set Combows = ThisWorkbook.Sheets("Combined Plates")
Set rng = Combows.Range("C3:N66")
Set plates = Combows.Range("A2")
ArrayToCell BlockToList(rng, plates), Poolws.Range("A2") 'read by column
ArrayToCell BlockToList(rng, plates, False), Poolws.Range("F2") 'read by column
End Sub
'convert a rectangular range into a 2-d single-column array
' Read by row(default) or by column (pass False as second argument)
Function BlockToList(rng As Range, plates As Range, Optional rowMajor As Boolean = True)
Dim m As Long, n As Long, dr, dc, arrData, arrOut, platenum, i As Long
arrData = rng.Value
platenum = plates.Value
dr = UBound(arrData, 1)
dc = UBound(arrData, 2)
ReDim arrOut(1 To (dr * dc), 1 To 1)
If rowMajor Then
For m = 1 To dr
For n = 1 To dc
i = i + 1
arrOut(i, 1) = arrData(m, n)
Next n
Next m
Else
For m = 1 To dc
' I think something in the following lines needs to change.
' divide array by plantenum into that many arrays then on each
' run the following, pasting the results sequentially in a column
For n = 1 To dr / platenum
i = i + 1
arrOut(i, 1) = arrData(n, m)
Next n
Next m
End If
BlockToList = arrOut
End Function
'Utility method for populating an array to a range
Sub ArrayToCell(arr, rngDest As Range)
rngDest.Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub
Here's how I'd approach that:
Sub Tester()
Const PLT_ROWS As Long = 8
Const PLT_COLS As Long = 12
Dim rng As Range, arr, rngOut As Range
Dim Poolws As Worksheet
Dim Combows As Worksheet
Dim plates As Range
Set Poolws = ThisWorkbook.Sheets("Pools")
Set Combows = ThisWorkbook.Sheets("Combined Plates")
Set rng = Combows.Range("C3").Resize(PLT_ROWS, PLT_COLS)
Set rngOut = Poolws.Range("F2")
Do While Application.CountA(rng) > 0
ArrayToCell BlockToList(rng, False), rngOut 'by column or by row?
Set rng = rng.Offset(rng.Rows.Count, 0) 'next input block
Set rngOut = rngOut.Offset(0, 1) 'output next column over?
'Set rngOut = rngOut.Offset(rng.Cells.Count, 0) '...or append to previous?
Loop
End Sub
Rest of code from previous question is unchanged - in order to keep your code as modular as possible it's best to avoid special-casing your "core" methods where you can.
If you're dealing with multi-plate output files from an instrument, ideally you want to be reading directly from those files (typically after opening them in Excel so you don't need to do the parsing) with no intermediate copy/paste/consolidate steps.
I found a solution (for anyone who cares):
I added a loop that breaks the range/array/chunk into sections (in this case I know they are always 8 "tall"). I'm sure someone could have a better solution, but this one worked for me! Code as follows:
'convert a rectangular range into a 2-d single-column array
' Read by row(default) or by column (pass False as second argument)
Function BlockToList(rng As Range, plates As Range, Optional rowMajor As Boolean = True)
Dim m As Long, n As Long, o As Long, dr, dc, arrData, arrOut, platenum, i As Long
arrData = rng.Value
platenum = plates.Value
dr = UBound(arrData, 1)
dc = UBound(arrData, 2)
ReDim arrOut(1 To (dr * dc), 1 To 1)
If rowMajor Then
For m = 1 To dr
For n = 1 To dc
i = i + 1
arrOut(i, 1) = arrData(m, n)
Next n
Next m
Else
For o = 0 To platenum * 8
If ((o * 8) + 8) <= dr Then
For m = 1 To dc
' divide array by plantenum into that many arrays then on each
' run the following, pasting the results sequentially in a column
For n = ((o * 8) + 1) To ((o * 8) + 8)
i = i + 1
arrOut(i, 1) = arrData(n, m)
Next n
Next m
End If
Next o
End If
BlockToList = arrOut
End Function
I am using the followig code to convert decimals into %.
The number of datapoints in column B will change daily. How can I make the range dynamic so that the code works?
For Each c In [B2:B47]
If c.Value < 1 Then
c.Value = c.Value * 100
End If
c.NumberFormat = "0.00\%"
Next c
Thank you.
I always use a while loop for this task. The loop goes until it reaches a blank cell (i.e. the end of the data)
Sub ranges()
Dim c As Range
Dim n As Integer
n = 2
While Sheets("sheetname").Cells(n, 2) <> ""
Set c = Sheets("sheetname").Cells(n, 2)
If c.Value < 1 Then
c.Value = c.Value * 100
End If
c.NumberFormat = "0.00\%"
n = n + 1
Wend
End Sub
One method is to determine the first and last rows of the range.
Frequently, the first row is known and hard-coded; the last row can be found by starting at the bottom and moving up.
for example
'should always declare your variables
Dim r As Range, c As Range
'should always fully qualify the reference
With ThisWorkbook.Worksheets("sheet4")
Set r = Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp))
End With
For Each c In r
'do your thing
Next c
I'm trying to create a code that randomly selects a specific number of rows in a list. The problem that i want to prevent selecting empty rows and some specific value, for example "54555". Maybe someone could help me? Here's my code below
Sub Button1_Click()
Dim d As Object, r As Range, vKeys, x&
'get a set of 3 unique numbers
Set d = CreateObject("Scripting.Dictionary")
While d.Count < 3
'Define the min,max of your numbers
x = RndBetween(6, 11)
If Not d.Exists(x) Then d.Add x, Empty
Wend
'Create a multiarea range
vKeys = d.keys
Set r = Rows(vKeys(0))
For x = 1 To UBound(vKeys)
Set r = Union(r, Rows(vKeys(x)))
Next
'Select it
r.Select
Selection.Copy
Range("A1").Select
Worksheets("Ausinës").Paste
r.Delete
End Sub
Function RndBetween(low&, high&) As Long
RndBetween = CLng(Rnd * (high - low)) + low
End Function
This is an Excel problem.
I have an Excel Rows with the following values:
cell value 1, 2, x, ,1=,2=, ,x=,2
cell address a1,b1,c1,d1,e1,f1,g1,h1,i1
I want to get all non-empty cell addresses from the above row.
i.e.
a1,b1,c1,e1,f1,h1,i1
Is it possible using vba/vbs to do the job?
thank you very much
You can use .SpecialCells(xlCellTypeConstants)
To demonstrate, run this, and observe result in the Imediate window
Sub demo()
Dim rng As Range, rNonEmpty As Range
Set rng = [A1:I1]
Set rNonEmpty = rng.SpecialCells(xlCellTypeConstants)
Debug.Print rNonEmpty.Address
End Sub
The following code will check an area of 10 rows by 1000 columns and finally will show the addresses of the non blank cells in cell A20:
Sub no_blank_cells()
Dim wks As Worksheet
Set wks = ActiveSheet
m = ""
maxrows = 10
maxcolumns = 1000
For i = 1 To maxrows
For j = 1 To maxcolumns
a = Cells(i, j)
If a <> "" Then
m = m & Cells(i, j).Address(RowAbsolute:=False, ColumnAbsolute:=False) & ", "
End If
Next j
Next i
msg = MsgBox(m, vbInformation)
wks.Cells(20, 1) = m
End Sub
If you want to change the area to be searched, modify the value of the variables maxrowsand maxcolumns.
Sub WriteNonNulValue()
'/*SELECT SHEET TO ANALIZE*/
Worksheets("Sheet1").Select
'/*SELECT ROW TO READ*/
Row_to_read = 1
'/*SELECT ROW IN WHICH WRITE*/
Row_to_write = 2
'/*NUMBER OF COLUMNS TO ANALIZE*/
Columns_to_analize = 11
'/*COUNTER WRITE*/
Columns_to_write = 1
For i = 1 To Columns_to_analize
If Trim(Cells(Row_to_read, i)) <> "" Then
'/*WRITE ADDRESS NO EMPTY CELLS*/
Cells(Row_to_write, Columns_to_write) = Cells(Row_to_read,i).Address
'/*INCREMENT COUNTER WRITE*/
Columns_to_write = Columns_to_write + 1
End If
Next i
End Sub
Hello, I am doing a macro that copy the values on the columns, VALUES1, VALUES2, VALUES3 if it is not blank when the ARTICLE is the same.
I would have the first spreadsheet and I want the macro to return the second Spreadsheet.
I have managed how to make it:
Sub test()
Dim i, last, j, x As Integer
Dim R As Range
last = Sheets("List2").Range("A100000").End(xlUp).Row - 2
For i = 0 To last
Set R = Sheets("List2").Range("A2")
If Not WorksheetFunction.CountIf(Sheets("List2").Columns(1), _
Sheets("List2").Range("A2").Offset(i, 0).Value) = 0 Then
For j = 1 To WorksheetFunction.CountIf(Sheets("List2").Columns(1), _
Sheets("List2").Range("A2").Offset(i, 0).Value)
Set R = Sheets("List2").Columns(1).Find(Sheets("List2").Range("A2"). _
Offset(i, 0).Value, R, LookAt:=xlWhole)
For x = 0 To 2
If Not Sheets("List2").Range("B2").Offset(i, x).Value = "" Then
R.Offset(0, "1" + x).Value = Sheets("List2"). _
Range("B2").Offset(i, x).Value
End If
Next x
Next j
End If
Next i
End Sub
but the problem it takes too long, 'cause I have around 10.000 Rows and 20 Columns, and besides the Spreadsheet is not in order, so it could be to has a disorder, something like (A, B, B, A, ...)
Is there any way to make it faster o better???
Thanks a lot. Themolestones.
Here is a very easy solution with formulas to your problem:
Sheet2!A1=Sheet1!A1
Sheet2!B1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!B:B)
Sheet2!C1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!C:C)
Sheet2!D1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!D:D)
Put these formulas in the cells left of the = and copy down. You really need only the first two, because you can copy the second also to the right.
You need Sheet1 to be sorted by article.
That's it.
Of course, there might be occasions, when it is just necessary to implement this with VBA. Usually the fastest way to handle large amounts of cells with VBA, is to use array-copies of your ranges. Using worksheet-functions and looping through single cell references slows you down heavily.
Edit:
This would be my VBA solution
Public Sub Demo()
Dim arrRange() As Variant
Dim arrRangeResult() As Variant
Dim i As Long
Dim j As Long
Dim copyVal As Variant
Dim copyCond As Variant
Dim copyCol As Long
'create two copies of the origin data
arrRange = Range("A:D")
arrRangeResult = Range("A:D")
'loop through first data-copy, downwards through the articles
For i = LBound(arrRange, 1) + 1 To UBound(arrRange, 1)
'stop loop, if no article was found
If arrRange(i, 1) = "" Then Exit For
'store current article ID
copyCond = arrRange(i, 1)
'loop sideways through value-columns
For j = LBound(arrRange, 2) + 1 To UBound(arrRange, 2)
'store value & column, when found
If arrRange(i, j) <> "" Then
copyVal = arrRange(i, j)
copyCol = j
Exit For
End If
Next j
'loop through output array and paste value
For j = LBound(arrRangeResult, 1) + 1 To UBound(arrRangeResult, 1)
If arrRangeResult(j, 1) = copyCond Then
'paste-down found value to all occurences of article
arrRangeResult(j, copyCol) = copyVal
ElseIf arrRangeResult(j, 1) = "" Then
'early stop, when no article ID is found
Exit For
End If
Next j
Next i
'create output
Range("K:N") = arrRangeResult
End Sub