I don't know what I am doing wrong as the code below is able to ReDim Preserve the first iteration but not the second.
Dim inj0() As Variant
Dim i As Integer
Dim c As Integer
Dim Rng As Range
Dim pos As Integer
'Find the last used column in a Row
Dim LastCol As Integer
With ActiveSheet
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
End With
c = 0
For i = 1 To LastCol
pos = InStr(Cells(2, i), "80")
If pos = 1 Then
ReDim Preserve inj0(c, 2)
inj0(0, 1) = "80"
Set Rng = Cells(2, i)
inj0(c, 2) = Rng.Offset(-1, 0).Value
inj0(c, 0) = Rng.Offset(3, 0).Value
c = c + 1
End If
Next
Try to change the code as follows:
c = 0
ReDim inj0(2, 0)
inj0(1, 0) = "80"
For i = 1 To LastCol
pos = InStr(Cells(2, i), "80")
If pos = 1 Then
ReDim Preserve inj0(2, c)
Set Rng = Cells(2, i)
inj0(2, c) = Rng.Offset(-1, 0).Value
inj0(0, c) = Rng.Offset(3, 0).Value
c = c + 1
End If
Next
If you need the dimensions to be swapped, finally you can apply WorksheetFunction.Transpose method.
Related
Image1
Hi, Referring to the image, I am trying to compare column G and Column K, if the value is the same then copy the value in column J to column F. However, my code doesn't copy the value from Column J to F.
Sub createarray1()
Dim i As Integer
Dim j As Integer
Dim masterarray As Range
Set masterarray = Range("D3:G12")
Dim sourcearray As Range
Set sourcearray = Range("H3:K26")
For i = 1 To 10
For j = 1 To 25
If masterarray(i, 4).Value = sourcearray(j, 4).Value Then
masterarray(i, 3) = sourcearray(j, 3).Value
Else
masterarray(i, 3).Value = ""
End If
Next
Next
End Sub
Function concatenate()
Dim nlastrow As Long
For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
Cells(i, "G").Value = Cells(i, "D").Value & "_" & Cells(i, "E").Value
Next i
Dim nnlastrow As Long
For i = 2 To Cells(Rows.Count, "H").End(xlUp).Row
Cells(i, "K").Value = Cells(i, "H").Value & "_" & Cells(i, "I").Value
Next i
End Function
Use variant arrays, that way you limit the number of calls to the sheet to only 3.
When your positive is found you need to exit the inner loop.
Sub createarray1()
Dim i As Long
Dim j As Long
Dim masterarray As Variant
Dim sourcearray As Variant
With ThisWorkbook.Worksheets("Sheet1") ' change to your sheet
masterarray = .Range("D3:G12")
sourcearray = .Range("H3:K26")
For i = LBound(masterarray, 1) To UBound(masterarray, 1)
masterarray(i, 3) = ""
For j = LBound(sourcearray, 1) To UBound(sourcearray, 1)
If masterarray(i, 4) = sourcearray(j, 4) Then
masterarray(i, 3) = sourcearray(j, 3)
Exit For
End If
Next j
Next i
.Range("D3:G12") = masterarray
End With
End Sub
But this can all be done with the following formula:
=INDEX(J:J,MATCH(G3,K:K,0))
Put it in F3 and copy/drag down.
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
As shown below in image2 I have 3 sets of data having same elements in column1(order could be different) with different values in column2.I need a macro which will split the data at specific element(A) and paste the values of the respective element in column3..column4..column5 accordingly as shown in image1.
Here is the Expected output:
This is my current input data:
Give this a go. This assumes there is an A in every section and is used as the section divider
Public Sub Generate()
Dim rng As Range
Dim tmp As Variant
Dim c, key
Dim NoOfSets As Long
Dim Dict As Object
Dim i As Long, j As Long
Set Dict = CreateObject("Scripting.Dictionary")
Set rng = Range(Cells(1, 1), Cells(Cells(Rows.Count, "B").End(xlUp).Row, 2))
NoOfSets = Application.CountIf(rng, "A")
j = 1
For i = 1 To rng.Rows.Count
ReDim tmp(1 To NoOfSets)
If Not Dict.exists(rng.Cells(i, 1).Value2) Then
tmp(j) = rng.Cells(i, 2).Value2
Dict.Add key:=rng.Cells(i, 1).Value2, Item:=tmp
Else
If rng.Cells(i, 1) = "A" Then j = j + 1
tmp = Dict(rng.Cells(i, 1).Value2)
tmp(j) = rng.Cells(i, 2).Value2
Dict(rng.Cells(i, 1).Value2) = tmp
End If
Next i
j = 0
With Cells(1, 4)
For Each key In Dict.keys
.Offset(j, 0) = key
Range(.Offset(j, 1), .Offset(j, UBound(Dict(key)))) = Dict(key)
j = j + 1
Next key
End With
End Sub
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
I need help.
In a sheet I need concatenate with a loop the columns "a" + "b" + "c", next the columns "d" + "e" + "f", etc ... an go up to the last column.
My script is locked to the second loop...
The concatenated results are to appear in a second sheet.
this is my incorrect code:
Sub concatena()
Dim x As String
Dim Y As String
b = 1 'colonna selezionata
For c = 1 To 5 'colonne concatenate da riportare
For q = 1 To 10 'righe su cui effettuare l'operazione
For t = 1 To 3 'numero celle da concatenare
For Each cell In Worksheets(1).Cells(q, t)
If cell.Value = "" Then GoTo Line1
x = x & cell(1, b).Value & "" & ""
Next
Next t
Line1:
On Error GoTo Terminate
Worksheets(2).Cells(q, c).Value = Mid(x, 1, Len(x))
x = "" 'mantiene la formattazione
Next q
b = 3 + 1 ' sposta il concatena di 3 celle la selezione delle colonne
Next c
Terminate: 'error handler
End Sub
Thank you all for the help!
This one uses arrays to speed it up a little:
Sub concatena()
Dim inArr() As Variant
Dim oArr() As Variant
Dim i&, j&
Dim ws As Worksheet
Dim rng As Range
Set ws = Worksheets("Sheet9") ' change to your worksheet
With ws
Set rng = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
inArr = rng.Value
ReDim oArr(1 To UBound(inArr, 1), 1 To UBound(inArr, 2) / 3)
For i = LBound(inArr, 1) To UBound(inArr, 1)
For j = LBound(inArr, 2) To UBound(inArr, 2) Step 3
oArr(i, Int((j - 1) / 3) + 1) = inArr(i, j) & inArr(i, j + 1) & inArr(i, j + 2)
Next j
Next i
rng.Clear
.Range("A1").Resize(UBound(oArr, 1), UBound(oArr, 2)).Value = oArr
End With
you can try this code:
Option Explicit
Sub concatena()
Dim iRow As Long, iCol As Long, iCol2 As Long
Dim arr As Variant
With Worksheets("numbers")
With .Cells(1, 1).CurrentRegion
ReDim arr(1 To .Rows.Count, 1 To .Columns.Count / 3 + .Columns.Count Mod 3)
For iRow = 1 To .Rows.Count
iCol2 = 1
For iCol = 1 To .Columns.Count Step 3
arr(iRow, iCol2) = Join(Application.Transpose(Application.Transpose(.Cells(iRow, iCol).Resize(, 3).Value)), "")
iCol2 = iCol2 + 1
Next iCol
Next iRow
Worksheets("results").Range("A1").Resize(.Rows.Count, UBound(arr, 2)).Value = arr
End With
End With
End Sub
This solution provides flexibility as it uses the variable bClls to hold the number of cells to be concatenated.
Assuming the source range is B2:M16 and you want to concatenate the value of every 3 cells for each row.
It avoids the use of redim.
Sub Range_Concatenate_Cells_TEST()
Dim rSel As Range
Dim bClls As Byte
Dim rCllOut As Range
bClls = 3 'change as required
Set rSel = ThisWorkbook.Sheets("Sht(0)").Range("B2:M16") 'change as required
Set rCllOut = ThisWorkbook.Sheets("Sht(1)").Cells(2, 2) 'change as required
Call Range_Concatenate_Cells(bClls, rSel, rCllOut)
End Sub
Sub Range_Concatenate_Cells(bClls As Byte, rSel As Range, rCllOut As Range)
Dim lRow As Long, iCol As Integer
Dim lRowOut As Long, iColOut As Integer
Dim vResult As Variant
With rSel
For lRow = 1 To .Rows.Count
lRowOut = 1 + lRowOut
iColOut = 0
For iCol = 1 To .Columns.Count Step 3
iColOut = 1 + iColOut
vResult = .Cells(lRow, iCol).Resize(1, 3).Value2
vResult = WorksheetFunction.Index(vResult, 0, 0)
vResult = Join(vResult, "")
rCllOut.Offset(-1 + lRowOut, -1 + iColOut).Value = vResult
Next: Next: End With
End Sub