I could not find any information on this problem in the Visual Basic language, but I am trying to generate 10 and only 10 random mines for a 5x5 Minesweeper game. My problem involves the number of mines. I often only generate 4 mines, or 10+ mines, and its always inconsistent. Here is my code:
Sub Minesweeper()
Dim i As Single
Dim Col As Single
Dim Row As Single
Dim BombArray(1 To 5, 1 To 5) As String
'assignment of mines
Do
Row = Application.WorksheetFunction.RandBetween(1, 5)
Col = Application.WorksheetFunction.RandBetween(1, 5)
1
If BombArray(Row, Col) <> "X" Then
BombArray(Row, Col) = "X"
Sheet1.Cells(4 + Row, 3 + Col).Value = BombArray(Row, Col)
Else
i = i + 1
GoTo 1
End If
Loop Until i = 10
End Sub
Any help would be greatly appreciated.
Use a standard for loop
Also since you are using an array assign the array only once after the loop:
Sub Minesweeper()
Dim i As Single
Dim Col As Single
Dim Row As Single
Dim BombArray(1 To 5, 1 To 5) As String
'assignment of mines
For i = 1 To 10
Row = Application.WorksheetFunction.RandBetween(1, 5)
Col = Application.WorksheetFunction.RandBetween(1, 5)
If BombArray(Row, Col) <> "X" Then
BombArray(Row, Col) = "X"
Else
i = i - 1
End If
Next i
Sheet1.Range("D5").Resize(UBound(BombArray, 1), UBound(BombArray, 2)).Value = BombArray
End Sub
Build a dictionary of mine locations and keep adding/overwriting until you reach 10.
Option Explicit
Sub Minesweeper()
Dim mines As Object
Set mines = CreateObject("scripting.dictionary")
Do While mines.Count < 10
mines.Item(Cells(Application.RandBetween(5, 9), Application.RandBetween(4, 8)).Address(0, 0)) = vbNullString
Loop
Debug.Print Join(mines.keys, ", ")
Sheet1.Range(Join(mines.keys, ", ")) = "x"
End Sub
Related
An analyst observed that the upward movement of stocks on Bovespa is repeated according to a mathematical sequence. He wants to find out what the next bullish sequences will be. Generate and save in Excel cells using macro the sequence 1, 3, 4, 7, 11, 18, 29, ... up to its twentieth term?
following my code in vba:
Sub GerarSequencia()
Dim num As Long
Dim previous As Long
Dim i As Integer
num = 0
previous = 0
For i = 1 To 20
If i = 1 Then
num = 1
Else
num = num + previous
End If
Cells(i, 1).Value = num
previous = num
Next i
End Sub
I tried to generate the sequence of the exercise but did it generate another one?
The sequence is a sommation of the earlier two values. So 1 + 3 = 4 and so on. Before you can start the sqequence you have to have two numbers. I think you can work with:
Sub GerarSequencia()
Dim intFirstNum, intSecondNum As Integer
Dim intCounter As Integer
intFirstNum = 1
intSecondNum = 3
Cells(1, 1) = intFirstNum
Cells(2, 1) = intSecondNum
For intCounter = 3 To 20
Cells(intCounter, 1).Value = Cells(intCounter - 2, 1).Value + Cells(intCounter - 1, 1).Value
Next intCounter
End Sub
So you see that I have made two additional variables which are filled with 1 and 3 (if you change them you can start wherever you want). From that point on, I start the loop from position 3. This is because the first two are already known.
From that point on you can run the sequence. You don't need an if statement in that case.
Generating a Sequence
Sub GerarSequencia()
Const nCOUNT As Long = 20
Dim nPrev As Long: nPrev = 1
Dim nCurr As Long: nCurr = 3
Cells(1, 1).Value = nPrev
Cells(2, 1).Value = nCurr
Dim nNext As Long
Dim i As Long
For i = 3 To nCOUNT
nNext = nPrev + nCurr ' sum up
Cells(i, 1).Value = nNext ' write
nPrev = nCurr ' swap
nCurr = nNext ' swap
Next i
' ' Return the worksheet results in the Immediate window (Ctrl + G).
' For i = 1 To 20
' Debug.Print Cells(i, 1).Value
' Next i
End Sub
I did not know how to explain the question so I will attach images for explaining my situation. Here is the view of my Excel Sheet:
My Excel Sheet
The highlighted cells contain multiple values called ID's and are associated with respective Versions in the columns beside them. I use the following macro (details with great explanation here) to split these values into multiple rows in the same sheet.
Option Explicit
Private Const ID_IDX As Long = 0
Private Const VER_IDX As Long = 1
Private Const RNG_IDX As Long = 2
Private Sub RunMe()
Dim data As Variant, cols As Variant, items As Variant
Dim r As Long, c As Long, i As Long, n As Long
Dim ids() As String, vers() As String
Dim addItems As Collection, concatItems As Collection
Dim dataRng As Range, rng As Range
Dim writeID() As Variant, writeVer() As Variant, writeConcat() As Variant
Dim dataStartRow As Long
On Error Resume Next
'Define the range we're interested in and read into an array.
With Sheet1 'adjust for your worksheet object
Set dataRng = Application.InputBox(prompt:="Select the Range of cells:", Type:=8)
End With
data = dataRng.Value2
dataStartRow = 2
'Find the two target columns
cols = AcquireIdAndVerCol(data, 3, 8)
If IsEmpty(cols) Then
MsgBox "Unable to find Id and Ver columns."
Exit Sub
End If
With dataRng
'Add a column next to the version number column.
.Columns(cols(VER_IDX)).Offset(, 1).Insert Shift:=xlShiftToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Add a column to our range.
'This is to cover the case that the rightmost column is the version number column.
Set dataRng = .Resize(, .Columns.Count + 1)
End With
'Find the rows that need to be split and concatenate the target strings.
Set addItems = New Collection
Set concatItems = New Collection
For r = dataStartRow To UBound(data, 1)
ids = Split(data(r, cols(ID_IDX)), vbLf)
vers = Split(data(r, cols(VER_IDX)), vbLf)
n = IIf(UBound(ids) >= UBound(vers), UBound(ids), UBound(vers))
If n = 0 Then 'it's just one line of text.
'Add concatenated text to list.
concatItems.Add data(r, cols(ID_IDX)) & " " & data(r, cols(VER_IDX))
ElseIf n > 0 Then 'it's multiple lines of text.
'Transpose the id array.
ReDim writeID(1 To UBound(ids) + 1, 1 To 1)
For i = 0 To UBound(ids)
writeID(i + 1, 1) = ids(i)
Next
'Transpose the version array.
ReDim writeVer(1 To UBound(vers) + 1, 1 To 1)
For i = 0 To UBound(ids)
writeVer(i + 1, 1) = vers(i)
Next
'Add concatenated text to list.
For i = 0 To n
concatItems.Add (IIf(UBound(ids) <= n And UBound(vers) <= n, ids(i) & " " & vers(i), Empty))
Next
'Add the range to be split to the collection.
addItems.Add Array(writeID, writeVer, dataRng.Rows(r + 1).Resize(n))
Else 'it's an empty cell
'Add empty item to concatenated list in order to keep alignment.
concatItems.Add Empty
End If
Next
Application.ScreenUpdating = False
'Split the ranges in the list.
If addItems.Count > 0 Then
For Each items In addItems
'Add the rows.
With items(RNG_IDX)
.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Set rng = .Offset(-.Rows.Count - 1).Resize(.Rows.Count + 1)
'Note: format your rng Range obect as desired here.
End With
'Write the id and version values.
rng.Columns(cols(ID_IDX)).Value = items(ID_IDX)
rng.Columns(cols(VER_IDX)).Value = items(VER_IDX)
Next
End If
'Write the concatenated values.
If concatItems.Count > 0 Then
ReDim writeConcat(1 To concatItems.Count + dataStartRow - 1, 1 To 1)
'Header to array.
writeConcat(1, 1) = "Concat values"
'Values from the collection to array.
i = dataStartRow
For Each items In concatItems
writeConcat(i, 1) = items
i = i + 1
Next
'Output array to range.
With dataRng.Columns(cols(VER_IDX) + 1)
.Value = writeConcat
.AutoFit
End With
End If
Application.ScreenUpdating = True
End Sub
Private Function AcquireIdAndVerCol(data As Variant, minCol As Long, maxCol As Long) As Variant
Dim result(1) As Long
Dim r As Long, c As Long, i As Long
Dim items() As String
'Check we're not operating outside bounds of data array.
If minCol < LBound(data, 2) Then minCol = LBound(data, 2)
If minCol > UBound(data, 2) Then minCol = UBound(data, 2)
If maxCol < LBound(data, 2) Then maxCol = LBound(data, 2)
If maxCol > UBound(data, 2) Then maxCol = UBound(data, 2)
'Loop through data to find the two columns.
'Once found, leave the function.
For r = 1 To UBound(data, 1)
For c = minCol To maxCol
items = Split(data(r, c), vbLf)
For i = 0 To UBound(items)
If result(ID_IDX) = 0 Then
If IsDocId(items(i)) Then
result(ID_IDX) = c
If result(VER_IDX) = 0 Then
Exit For
Else
AcquireIdAndVerCol = result
Exit Function
End If
End If
End If
If result(VER_IDX) = 0 Then
If IsDocVer(items(i)) Then
result(VER_IDX) = c
If result(ID_IDX) = 0 Then
Exit For
Else
AcquireIdAndVerCol = result
Exit Function
End If
End If
End If
Next
Next
Next
End Function
Private Function IsDocId(val As String) As Boolean
Dim n As Long
n = TryClng(val)
IsDocId = (n > 9999 And n <= 999999999)
End Function
Private Function IsDocVer(val As String) As Boolean
Dim n As Long, m As Long
Dim items() As String
items = Split(val, ".")
If UBound(items) <> 1 Then Exit Function
n = TryClng(items(0))
m = TryClng(items(1))
IsDocVer = (n > 0 And n <= 99) And (m >= 0 And m <= 9)
End Function
'-------------------------------------------------------------------
'Converts a variant to a Long or returns a fail value as a Long
'if the conversion failed.
'-------------------------------------------------------------------
Private Function TryClng(expr As Variant, Optional fail As Long = -1) As Long
Dim n As Long
n = fail
On Error Resume Next
n = CLng(expr)
On Error GoTo 0
TryClng = n
End Function
It gives the following output with an addition column named, Concat Values, which contains combined values of Id's and corresponding Versions:
Output
Problem:
It works flawlessly if all the ID's have corresponding Versions specified in the sheet separately as I mentioned above. However in cases, where there is only one Version number, and it's bound to 4 or more Id's, i.e. Same Version number is applicable for all the ID's, like such:
The output in the column Concat Values gets disoriented because we are using an array to output the Concat Values and the array is not accommodating the missing Versions for corresponding Id's. It looks like this:
Dislocated row values
I am trying to learn and figure out a way to update the collection and the array with new Concat Values before Outputting it to the column, so that each Concat Value gets placed in their corresponding ID and Version location. I hope that it makes sense. Please let me know for more clarification.
EDIT:
I will try and list all the possible Cases and Expected Output, including the worst case scenarios:
Here is the link to my excel sheet.
Usual Scenarios
Number of Id's = Number of Versions (Works perfectly, Concat Values get aligned in corresponding rows in the columns)
Multiple Id's - Single Version (In such cases, the Version # applicable to all the ID's is same i.e. one Version should be applied to all the ID's.)
Issue:
The Macro does the task of splitting the columns into rows, except the part where Concat values get misaligned.
Worst Case Scenarios
Multiple Id's - Multiple Versions, but less than total #ID's (In such cases, Versions should align to the topmost ID's and fill the ID's below with blanks)
Issue:
The Macro does the task of splitting the columns into rows, except the part where Concat values get misaligned.
Here 4 ID's have been given only 3 Versions, so Top 3 ID's are assigned 3 Versions and the 4th ID has no Version linked to it.
Similarly,
Here 4 ID's have been given only 2 Versions, so Top 2 ID's are assigned 2 Versions and the 3rd and 4th ID's have no Version linked to them.
Multiple Id's - No Version (In such cases, columns should split into rows based on #ID's and corresponding Version rows should be filled with blanks)
Issue:
The Macro does the task of splitting the columns into rows, except the part where Concat values get misaligned.
The complexity of the solution will depend on the complexity and variety of 'special cases'. Given your scenarios, it seems as if you could just take the last of the given versions and, for any versions missing below that line, just use that last used version.
When I gave my first answer, I anticipated this kind of issue, so changes to the code are trivial.
Firstly add an additional declaration in the RunMe Sub:
Dim curVer As String
and then you just need to adjust the ElseIf n > 0 case. Replace the code with this:
ElseIf n > 0 Then 'it's multiple lines of text.
'Resize the output arrays to max ('n')
ReDim writeID(1 To n + 1, 1 To 1)
ReDim writeVer(1 To n + 1, 1 To 1)
'Loop through the arrays to align id and versions.
For i = 0 To n
If i <= UBound(ids) Then
writeID(i + 1, 1) = ids(i)
End If
If i <= UBound(vers) Then
curVer = vers(i)
End If
writeVer(i + 1, 1) = curVer
Next
'Add concatenated text to list.
For i = 0 To n
concatItems.Add writeID(i + 1, 1) & " " & writeVer(i + 1, 1)
Next
'Add the range to be split to the collection.
addItems.Add Array(writeID, writeVer, dataRng.Rows(r + 1).Resize(n))
Too much code for me to read but I came up with my solution if I understood you problem correctly.
I guess it could be a good solution if you modify it. With my code it will be easier to produce a new table instead of adding rows I guess. Then you could just add the formatting which should be very easy.
Sub Test()
Dim xRange As Range
Dim xArrRange() As Variant
Dim xNewArrRange() As Variant
Dim xNewArrRangeResize() As Variant
Dim xNumberColumns As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim ii As Long
Dim jj As Long
Set xRange = Range("A2:C5")
xNumberColumns = 3
xArrRange = xRange.Value2
ReDim xNewArrRange(xRange.Rows.Count + 10, xNumberColumns) ' "xNumberColumns - 1" to have the number of columns
' "xNumberColumns" is one more
For i = LBound(xArrRange, 1) To UBound(xArrRange, 1)
Dim xTempArrVer As Variant
Dim xTempArrID As Variant
xTempArrVer = Split(xArrRange(i, 3), vbLf)
If UBound(xTempArrVer) = -1 Then ' If there are no version, initialize it with ""
ReDim xTempArrVer(0)
xTempArrVer(0) = ""
End If
xTempArrID = Split(xArrRange(i, 2), vbLf)
For j = LBound(xTempArrID, 1) To UBound(xTempArrID, 1)
If j > UBound(xTempArrVer, 1) Then
l = UBound(xTempArrVer, 1)
Else
l = j
End If
xNewArrRange(k, 0) = xArrRange(i, 1)
xNewArrRange(k, 1) = xTempArrID(j)
xNewArrRange(k, 2) = xTempArrVer(l)
If xTempArrVer(l) <> "" Then
xNewArrRange(k, 3) = xTempArrID(j) & " " & xTempArrVer(l)
Else
xNewArrRange(k, 3) = xTempArrID(j)
End If
k = k + 1
If k + 1 > UBound(xNewArrRange, 1) Then
ReDim Preserve xNewArrRange(UBound(xNewArrRange, 1) + 30, xNumberColumns)
End If
Next j
Next i
ReDim xNewArrRangeResize(k - 1, xNumberColumns) ' "xNumberColumns - 1" to have the number of columns
' "xNumberColumns" is one more
For ii = LBound(xNewArrRangeResize, 1) To UBound(xNewArrRangeResize, 1)
For jj = LBound(xNewArrRangeResize, 2) To UBound(xNewArrRangeResize, 2)
xNewArrRangeResize(ii, jj) = xNewArrRange(ii, jj)
Next jj
Next ii
Range(Cells(2, 6), Cells(UBound(xNewArrRangeResize, 1) + 1, 6 + UBound(xNewArrRangeResize, 2))).Value2 = xNewArrRangeResize
Debug.Print "Finish"
End Sub
This code produces this:
If your code produces good number of rows for each id etc, the most lazy solution would be just to populate columns of your table with part of my array which is produced at the end.
Edit:
I see there is something missing but that is because I calculated wrongly that Range.
Range(Cells(2, 6), Cells(UBound(xNewArrRangeResize, 1) + 1, 6 + UBound(xNewArrRangeResize, 2))).Value2 = xNewArrRangeResize
I want to make a sub, which determines if the cells in the 12th column starts with 262015. If it does start with this, it should create a new random 8-digit number starting with "18" and then 6 randomly created unique digits.
My code does not seem to figure out if the cell starts with 262015, and I have not been able to find help on creating the 8-digit number with these requirements.
Hope you can help me!
Sub Opgave8()
For i = 2 To 18288
If Left(Worksheets("arab").Cells(i, 12), 6) = "262015" Then
Worksheets("arab").Cells(i, 3) = "18" & studyid(6)
End If
Next i
Function UniqueRandDigits(x As Long) As String
Dim i As Long
Dim n As Integer
Dim s As String
Do
n = Int(Rnd() * 10)
If InStr(s, n) = 0 Then
s = s & n
i = i + 1
End If
Loop Until i = x + 1
UniqueRandDigits = s
End Function
End Sub
For i = 2 To 18288
If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
Worksheets("Base").Cells(i, 3) = "18" & Randdigits(6)
End If
Next i
Function RandDigits(x As Long) As String
Dim i As Long
Dim s As String
For i = 1 To x
s = s & Int(Rnd() * 10)
Next i
RandDigits = s
End Function
EDIT: here's one where all digits are different
Function UniqueRandDigits(x As Long) As String
Dim i As Long
Dim n As Integer
Dim s As String
Do
n = Int(Rnd() * 10)
If InStr(s, n) = 0 Then
s = s & n
i = i + 1
End If
Loop Until i = x + 1
UniqueRandDigits = s
End Function
EDIT2: And here is one that forces all numbers to be different
dim n as string
dim ok as boolean
For i = 2 To 18288
If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
ok = false
do
n = UniqueRandDigits(6)
If Application.WorksheetFunction.CountIf(Worksheets("Base").Range("L2:L18288"), n) = 0 Then
Worksheets("Base").Cells(i, 3) = "18" & n
ok = true
end if
loop until ok
End If
Next i
Using Left function, you need to specify the String, then the number of characters from the left, and then you check if it's equal to "262015".
Try the code below:
For i = 2 To 18288
If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
Worksheets("Base").Cells(i, 3) = "XXX"
End If
Next i
I'm trying to figure out a way to combine rows based on values in two specific columns in vba excel.
For Example:
Let's say I have the following sheet:
Column A Column J Column Z
1 A ?
1 A !
2 B ?
2 B !
And I need to convert it to this:
Column A Column J Column Z
1 A ?, !
2 B ?, !
Here's another method using User Defined Types and collections to iterate through the list and develop the combined results. For large sets of data, it should be considerably faster than reading through each cell on the worksheet.
I assume that you are grouping on Col J, and that Column A data does not need to be concatenated in the cell. If it does, the modifications to the routine would be trivial.
First, Insert a Class Module, rename it CombData and insert the following code into that module:
Option Explicit
Private pColA As String
Private pColJ As String
Private pColZConcat As String
Public Property Get ColA() As String
ColA = pColA
End Property
Public Property Let ColA(Value As String)
pColA = Value
End Property
Public Property Get ColJ() As String
ColJ = pColJ
End Property
Public Property Let ColJ(Value As String)
pColJ = Value
End Property
Public Property Get ColZConcat() As String
ColZConcat = pColZConcat
End Property
Public Property Let ColZConcat(Value As String)
pColZConcat = Value
End Property
Then Insert a Regular Module and insert the Code Below:
Option Explicit
Sub CombineData()
Dim cCombData As CombData
Dim colCombData As Collection
Dim V As Variant
Dim vRes() As Variant 'Results Array
Dim rRes As Range 'Location of results
Dim I As Long
'read source data into array
V = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=26)
'Set results range. Here it is set below the Source Data
'Could be anyplace, even on a different worksheet; or could overlay the
' original. Area below and to right is cleared
Set rRes = Range("A1").Offset(UBound(V) + 10)
Range(rRes, rRes.SpecialCells(xlCellTypeLastCell)).Clear
Set colCombData = New Collection
On Error Resume Next
For I = 1 To UBound(V)
Set cCombData = New CombData
cCombData.ColA = V(I, 1)
cCombData.ColJ = V(I, 10)
cCombData.ColZConcat = V(I, 26)
colCombData.Add cCombData, CStr(cCombData.ColJ)
If Err.Number <> 0 Then
Err.Clear
With colCombData(cCombData.ColJ)
.ColZConcat = .ColZConcat & ", " & V(I, 26)
End With
End If
Next I
On Error GoTo 0
ReDim vRes(1 To colCombData.Count, 1 To 26)
For I = 1 To UBound(vRes)
With colCombData(I)
vRes(I, 1) = .ColA
vRes(I, 10) = .ColJ
vRes(I, 26) = .ColZConcat
End With
Next I
rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes
End Sub
EDIT: Note that the source data is read into the Variant array V. If you examine V in the Watch Window, you will see that the first dimension represents the rows; and the second dimension the columns. So if you wanted, for example, to perform the same procedure on a different set of columns, you would merely change the references to the second dimension under the line that reads Set cCombData = New CombData. For example, column B data would be V(I,2), and so forth. Of course, you might want to rename the data types to make them more representative of what you are doing.
In addition, if your data starts at row 2, merely start the iteration through V with I = 2 instead of I = 1.
EDIT2: In order to both overwrite the original, and also maintain the contents of the columns not being processed, the following modification will do that for Columns A, J and Z. You should be able to modify it for whatever columns you choose to process.
Option Explicit
Sub CombineData()
Dim cCombData As CombData
Dim colCombData As Collection
Dim V As Variant
Dim vRes() As Variant 'Results Array
Dim rRes As Range 'Location of results
Dim I As Long, J As Long, K As Long
'read source data into array
V = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=26)
'Set results range. Here it is set below the Source Data
'Could be anyplace, even on a different worksheet; or could overlay the
' original. Area below and to right is cleared
Set rRes = Range("A1") '.Offset(UBound(V) + 10)
Range(rRes, rRes.SpecialCells(xlCellTypeLastCell)).Clear
Set colCombData = New Collection
On Error Resume Next
For I = 1 To UBound(V)
Set cCombData = New CombData
cCombData.ColA = V(I, 1)
cCombData.ColJ = V(I, 10)
cCombData.ColZConcat = V(I, 26)
colCombData.Add cCombData, CStr(cCombData.ColJ)
If Err.Number <> 0 Then
Err.Clear
With colCombData(cCombData.ColJ)
.ColZConcat = .ColZConcat & ", " & V(I, 26)
End With
End If
Next I
On Error GoTo 0
ReDim vRes(1 To colCombData.Count, 1 To 26)
For I = 1 To UBound(vRes)
With colCombData(I)
vRes(I, 1) = .ColA
vRes(I, 10) = .ColJ
vRes(I, 26) = .ColZConcat
'Note the 10 below is the column we are summarizing by
J = WorksheetFunction.Match(.ColJ, WorksheetFunction.Index(V, 0, 10), 0)
For K = 1 To 26
Select Case K 'Decide which columns to copy over
Case 2 To 9, 11 To 25
vRes(I, K) = V(J, K)
End Select
Next K
End With
Next I
rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes
End Sub
This is assuming that Column J is the key and Column A doesn't need to be appended. If Column A needs to be combined as well (not always the same), you would simply need to add another for each loop to check if the data is there, and add it if not, as done for col 26 in the code.
Sub CombineData()
x = 2
Do Until Cells(x, 1) = "" 'loop through every row in sheet starting at 2 (1 will never be removed, since it is the first data)
x2 = 1
Do Until x2 = x
If Cells(x, 10) = Cells(x2, 10) Then 'this is comparing column J. If another column is the reference then change 10 to the column number
splt = Split(Cells(x, 26), ", ")
For Each s In splt 'check to see if data already in column z
If s = Cells(x2, 26) Then GoTo alreadyEntered
Next
Cells(x, 26) = Cells(x, 26) & ", " & Cells(x2, 26) 'append column z data to row x
alreadyEntered:
Rows(x2).Delete Shift:=xlUp 'delete duplicate row
x = x - 1 'to keep x at same row, since we just removed a row
Exit Do
Else
x2 = x2 + 1
End If
Loop
x = x + 1
Loop
End Sub
I am receiving a large file 500k+ lines but all the content is in column A. I need to run a macro that will transpose the data into matrix form but will only create a new row when it finds "KEY*" in the ActiveCell. For example:
| KEY 4759839 | asljhk | 35049 | | sklahksdjf|
| KEY 359 | skj | 487 |y| 2985789 |
The above data in my file would originally look like this in column A:
KEY 4759839
asljhk
35049
sklahksdjf
KEY 359
skj
487
y
2985789
Considerations:
Blank cells need to be transposed as well, so the macro cant stop based on emptyCell
The number of cells between KEY's is not constant so it actually needs to read the cell to know if it should create a new row
It can either stop based on say 20 empty cells in a row or prompt for a max row number
(Optional) It would be nice if there was some sort of visual indicator for the last item in a row so that its possible to tell if the last item(s) were blank cells
I searched around and found a macro that had the same general theme but it went based on every 6 lines and I did not know enough to try to modify it for my case. But in case it helps here it is:
Sub kTest()
Dim a, w(), i As Long, j As Long, c As Integer
a = Range([a1], [a500000].End(xlUp))
ReDim w(1 To UBound(a, 1), 1 To 6)
j = 1
For i = 1 To UBound(a, 1)
c = 1 + (i - 1) Mod 6: w(j, c) = a(i, 1)
If c = 6 Then j = j + 1
Next i
[c1].Resize(j, 6) = w
End Sub
I would greatly appreciate any help you can give me!
This works with the sample data you provided in your question - it outputs the result in a table starting in B1. It runs in less than one second for 500k rows on my machine.
Sub kTest()
Dim originalData As Variant
Dim result As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim countKeys As Long
Dim countColumns As Long
Dim maxColumns As Long
originalData = Range([a1], [a500000].End(xlUp))
countKeys = 0
maxColumns = 0
'Calculate the number of lines and columns that will be required
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
countKeys = countKeys + 1
maxColumns = IIf(countColumns > maxColumns, countColumns, maxColumns)
countColumns = 1
Else
countColumns = countColumns + 1
End If
Next i
'Create the resulting array
ReDim result(1 To countKeys, 1 To maxColumns) As Variant
j = 0
k = 1
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
j = j + 1
k = 1
Else
k = k + 1
End If
result(j, k) = originalData(i, 1)
Next i
With ActiveSheet
.Cells(1, 2).Resize(UBound(result, 1), UBound(result, 2)) = result
End With
End Sub
Tested and works:
Sub test()
Row = 0
col = 1
'Find the last not empty cell by selecting the bottom cell and moving up
Max = Range("A650000").End(xlUp).Row 'Or whatever the last allowed row number is
'loop through the data
For i = 1 To Max
'Check if the left 3 characters of the cell are "KEY" and start a new row if they are
If (Left(Range("A" & i).Value, 3) = "KEY") Then
Row = Row + 1
col = 1
End If
Cells(Row, col).Value = Range("A" & i).Value
If (i > Row) Then
Range("A" & i).Value = ""
End If
col = col + 1
Next i
End Sub