I have one array with Sheet Names called SheetNames and I want to generate a sub array of it that only returns True at the condition (IF). I try to have a loop into a cell value onto different sheets, evaluating condition cell.value = "S". When checks that for the first D column (z = 4) I want to make the same check (IF condition) for columns D to DR at the same row.
I need to get similar result if I use formula at
Diary!C7
= IF (element!D6 = "S",CONCATENATE (element!B1, ", "), ""),
IF (element1!D6 = "S",CONCATENATE (element1!B1, ", "), ""), ....
IF (element!E6 = "S",CONCATENATE (element!B1, ", "), ""),
IF (element1!E6 = "S",CONCATENATE (element1!B1, ", "), "") .... )
Where element is a sheet name taken from an array with the sheet names who get the condition (Code S or another code).
SheetNames is one array with all the book sheets and FSheet (Filtered Sheet with condition) an array with only the filtered (with condition IF). When I can populate FSheet array for each sheet I test the condition then I must concatenate it's values at another sheet/cell and began the test condition again to the next cell (E6) ... But I'm trapped at the step to create FSheet.
Sub Test()
Dim ws As Worksheet
Dim SheetNames() As String, FSheets() As String, q As String
Dim element As Variant
Dim lastSheet As Integer, r As Integer, incrSheet As Integer, i As Integer
Dim Rgn As Range
' Enter the sheet names into an array. Redim array's size to the number of sheets (lastSheet)
For Each ws In ActiveWorkbook.Worksheets
ReDim Preserve SheetNames(lastSheet)
SheetNames(lastSheet) = ws.name
lastSheet = lastSheet + 1
Next ws
MsgBox lastSheet
' Test condition for each sheet/cell
For z = 4 To 11
For Each element In SheetNames()
incrSheet = 1
If ActiveWorkbook.Sheets(element).Cells(6, z).Value = "S" Then
ReDim Preserve FSheets(incrSheet)
FSheets(incrSheet) = element
incrSheet = incrSheet + 1
End If
Next element
Next z
i = 3
' Define the sheet to work (total project will have more than one, one for code we need test, S, C, etc)
With Worksheets("Diary")
.Activate
.Range("C7").Select
' Concatenate values at Summary page
Do
Cells(7, i).Select
For r = 1 To UBound(FSheets)
'Concatenate with &:
varConctnt = varConctnt & ", " & FSheets(r)
Next r
'remove the "&" before the first element:
varConctnt = Mid(varConctnt, 2)
q = varConctnt
varConctnt = ""
i = i + 1
ActiveCell.Value = q
Loop While i < 11
' Drag the formula for the rest of the rows
Range("C7:J7").Select
Selection.AutoFill Destination:=Range("C7:J12"), Type:=xlFillDefault
End With
End Sub
Where you are going wrong, is your attempt to dynamically set the range. Assuming you are testing the value of a single cell, it is much easier to use Cells, rather than Range, since you can use R1C1 notation. Try something like this:
incrSheet = 1
For z = 4 To 11
For Each element In SheetNames()
If ActiveWorkbook.Sheets(element).Cells(6, z).Value = "S" Then
ReDim Preserve FSheets(incrSheet)
FSheets(incrSheet) = element
MsgBox incrSheet
incrSheet = incrSheet + 1
End If
Next element
Next z
Related
I'm trying to look for values to create a final ticket number for a ticket reconciliation process. This is what should happen:
subroutine looks for a value in cell "Gx"
if it finds a value
pass value to function to strip out letters, convert to a number, pass back to subroutine to place in
cell "Ax"
if there is no value
pass value of "Cx" to function etc.
This loops through the number cells I have in my worksheet based on the number of rows filled in a separate column.
The function works fine by itself in the worksheet, but when I pass it a value from the subroutine column A fills up with the number of the row ie. A37=37, A8=8. I don't think I'm passing the argument correctly to the function, but I'm not certain. Here's the code for the subroutine and the function:
Sub final_ticket_number()
Dim rw As Integer
Dim i As Integer
'header label
Range("A1").Value = "Final Ticket #"
'set number of rows for loop
With Worksheets(1)
rw = .Range("B2").End(xlDown).Row
End With
'check col G for empty, use col C as backup
For i = 2 To rw
If Not IsEmpty(Cells(i, "G")) Then
'strip out letters in col G, place in col A
Cells(i, "A").Value = getNumeric("G" & i)
Else
'strip out letters in col C, place in col A
Cells(i, "A").Value = getNumeric("C" & i)
End If
Next i
End Sub
Function getNumeric(cellRef As String) As Long 'remove letters from ticket numbers
Dim stringLength As Integer
Dim i As Byte
Dim Result As String
stringLength = Len(cellRef)
'loops through each character in a cell to evaluate if number or not
For i = 1 To stringLength
If IsNumeric(Mid(cellRef, i, 1)) Then
Result = Result & Mid(cellRef, i, 1)
End If
Next i
'convert remaining characters to number
getNumeric = CLng(Result)
End Function
What am I missing?
As I understand it, the only thing that is wrong is your Len (cellRef), here you are only passing the range and not his value. See how I did it, I had to specify the spreadsheet, do the same that will work.
Use debug.print to see the outputs of the variables. Write in the code "debug.print XvariableX" and in the immediate check (Ctrl + G) you see the value assigned to the variable. good luck.
Sub final_ticket_number()
Dim rw As Integer
Dim i As Integer
Range("A1").Value = "Final Ticket #"
With Worksheets(1)
rw = .Range("B2").End(xlDown).Row
End With
For i = 2 To rw
If Not IsEmpty(Cells(i, "G")) Then
Cells(i, "A").Value = getNumeric("G" & i)
Else
Cells(i, "A").Value = getNumeric("C" & i)
End If
Next i
End Sub
Function getNumeric(cellRef As String) As Long 'remove letters from ticket numbers
Dim stringLength As Integer
Dim i As Byte
Dim Result As String
Dim Wrs As String
Wrk = ActiveWorkbook.Name
Workbooks(Wrk).Activate
Wrs = ActiveSheet.Name
stringLength = Len(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef))
For i = 1 To stringLength
If IsNumeric(Mid(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef), i, 1)) Then
Result = Result & Mid(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef), i, 1)
End If
Next i
getNumeric = CLng(Result)
End Function
I'm collecting data from a spreadsheet and storing it in a 2-D Array, the idea is that once the script detects it's reading from a specific column, it would not read an entire row of the data (as this would be considered a duplicate).
CODE:
Private Sub LoadData()
cDOC_DEBUG "Loading document data..."
Dim x As Long 'Column Data - there is another function that reads when x = 0 = header; else every other value is considered "data"
Dim y As Long
With dataWS
For x = 1 To LR - 1
For y = 1 To LC - 1
If (IsInArray(.Cells(x + 1, y + 1).value, pData())) Then
cDOC_DEBUG "Added: " & .Cells(x + 1, y + 1).value
pData(x, y) = Trim(.Cells(x + 1, y + 1).value)
End If
Next y
Next x
End With
End Sub
Private Function IsInArray(stringToBeFound As String, arrString As Variant) As Boolean
IsInArray = (UBound(Filter(arrString, stringToBeFound)) > -1)
End Function
Private Sub cDOC_DEBUG(debugText As String)
If (ThisWorkbook.Worksheets("Settings").Cells(3, 2)) Then
Debug.Print debugText
End If
End Sub
Everything is loading into the array fine, until I start implementing my IsInArray function. I can see it has to do with the fact that it's searching through a single dimensional array, and my array is two dimensional; so it makes sense that it's getting a type mismatch error.
Each row within the spreadsheet is a segment of information that correlates to it's self.
Initial Data From Spreadsheet:
A B C D
1 header1 header2 header3 header4
2 a b c d
3 w x y z
4 a h j j
5 a b j d
6 w x u z
2x2 Final Array:
0 1 2 3
0 header1 header2 header3 header4
1 a b c d
2 w x y z
3 a h j j
Because Header1 & Header2 & Header4 from Excel rows 5 & 6 have the same values as Excel rows 2 and 3, this will not be read into the array.
Question:
How would I match the criteria above to not include the duplicates from a row.
Example Sudo Code:
If (Value being added matches all values from column Header1 & Header2 & Header3_ Then
Don't add to array
Another issue that I am aware of, is that there will be blank data within this array; is there something I can do to either 1 remove these or will I have to have another index for the array slots to keep track of?
You can loop rows/columns and use Index to slice a row/column out of the array and use Match to test if search value is in that column. Combine with Count to test for duplicates. If the count equals the number of columns ignore value (or column count -1... see next comment ==>). Not entirely sure about this imaginary column. Do you intend to dimension at start with an additional empty column?
Row Versions:
Exists:
Option Explicit
Public Sub CheckRow()
Dim arr(), i As Long
arr = [A1:D6].Value '<==2D array created
For i = LBound(arr, 1) To UBound(arr, 1) '<== loop rows
'look in each row for x and if found exit loop and indicate row where found
If Not IsError(Application.Match("x", Application.WorksheetFunction.Index(arr, i, 0), 0)) Then
Debug.Print "value found in column " & i
Exit For
End If
Next
End Sub
Duplicates:
Option Explicit
Public Sub CheckRow()
Dim arr(), i As Long
arr = [A1:D6].Value '<==2D array created
For i = LBound(arr, 1) To UBound(arr, 1) '<== loop rows
'look in each row for more than one "B" and if found exit loop and indicate row where found
If Application.Count(Application.Match(Application.WorksheetFunction.Index(arr, i, 0), "B", 0)) > 1 Then
Debug.Print i
Exit For
End If
Next
End Sub
exists:
Columns versions:
Exists:
Option Explicit
Public Sub CheckColumn()
Dim arr(), i As Long
arr = [A1:D6].Value '<==2D array created
For i = LBound(arr, 2) To UBound(arr, 2) '<== loop columns
'look in each column for x and if found exit loop and indicate column where found
If Not IsError(Application.Match("x", Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Index(arr, 0, i)), 0)) Then
Debug.Print "value found in column " & i
Exit For
End If
Next
End Sub
Duplicates:
You can use Count to check for duplicates within an entire column, again sliced with Index:
Option Explicit
Public Sub CheckColumn()
Dim arr(), i As Long
arr = [A1:D6].Value '<==2D array created
For i = LBound(arr, 2) To UBound(arr, 2) '<== loop columns
'look in each column for more than one "B" and if found exit loop and indicate column where found
If Application.Count(Application.Match(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Index(arr, 0, i)), "B", 0)) > 1 Then
Debug.Print i
Exit For
End If
Next
End Sub
Using sample data in sheet:
Alternative using advanced Index function
This approach using a (late bound) dictionary should be helpful, if your data rows don't exceed the number of 65536. You'll get a 2-dim (1-based) array v with the unique data set of columns A,B and D.
In this example code results are written back to e.g. columns F:H and values of column C are omitted; if you want to maintain these values see ► Edit below.
Example code (omitting column C in resulting array)
Sub getUniqueRows()
Dim dict As Object, v, i&, ii&, n&, currRow$
Set dict = CreateObject("Scripting.Dictionary") ' late binding dictionary
With ThisWorkbook.Worksheets("MySheet") ' << change to your sheet name
n = .Cells(.Rows.Count, "A").End(xlUp).Row - 1 ' n items (omitting header line)
' [1] get data
v = .Range("A2:D" & n + 1).Value
' [2a]remove column C (i.e. allow columns 1, 2 and 4 only)
v = Application.Index(v, Evaluate("row(1:" & n & ")"), Array(1, 2, 4))
' [2b] check for unique ones
For i = 1 To n
currRow = Join(Application.Index(v, i, 0), ",") ' build string of cells A,B & D
If Not dict.Exists(currRow) Then dict.Add currRow, i
Next i
' [3] remove duplicate rows
v = Application.Transpose(Application.Index(v, dict.Items, Evaluate("row(1:" & 3 & ")")))
' [4] write data to any wanted range
.Range("F:H") = "" ' clear rows
.Range("F2").Resize(UBound(v), 3) = v ' write data
End With
Set dict = Nothing
End Sub
Note
The dict.Items collection in section [3] is an array of all found item numbers in the dictionary and allows the Index function to get only these items.
Additional links
See Insert new first column in datafield array without loops or API call
Edit - maintain values in column C
Due to comment: "ONLY using columns A, B, and D; Column C was not including in the criteria."
If you want to check values only in A,B and D, but maintain the C values in the resulting array you can use the following optimized code neglecting an empty values row.
Sub getUniqueRows2()
Dim dict As Object, v, i&, n&, j&, currRow$
Set dict = CreateObject("Scripting.Dictionary") ' late binding dictionary
With ThisWorkbook.Worksheets("MySheet") ' << change to your sheet name
n = .Cells(.Rows.Count, "A").End(xlUp).Row - 1 ' items counter (omitting header line)
' [1] get data
v = .Range("A2:D" & n + 1).Value
' [2] check for unique ones
For i = 1 To UBound(v)
' assign ONLY criteria of 1st, 2nd & 4th column to string value currRow
currRow = ""
For j = 0 To 2: currRow = currRow & v(i, Array(1, 2, 4)(j)) & ",": Next j
' add first unique occurrence to dictionary
If Not dict.Exists(currRow) Then ' add first occurrence
If Len(currRow) > 3 Then dict.Add currRow, i ' ... and ignore empty values
End If
Next i
' [3] remove duplicate rows
v = Application.Transpose(Application.Index(v, dict.Items, Evaluate("row(1:" & 4 & ")")))
' [4] write resulting array values anywhere, e.g. to columns F:I
.Range("F:I") = "" ' clear rows
.Range("F2").Resize(UBound(v), 4) = v ' write data
End With
Set dict = Nothing
End Sub
Currently using this code, however, I have a huge set of data, and this runs really slow for that. I need to remove any duplicate information, and keep the highest row of information.
dim dup as variant, r as long, lncheckduplicatescolumn as long
With wb_DST.Sheets(sWs_DST)
lncheckduplicatescolumn = .Cells(.Rows.Count, "A").End(xlUp).row
for r = lncheckduplicatescolumn to 2 step -1
dup = application.match(.cells(r, "A").value, .columns(1), 0)
if dup < r then .rows(dup).delete
next r
end with
Data:
Column A Column B
A 1
B 2
C 3
A 3
Result should be:
B 2
C 3
A 3
The order of data in column A doesnt matter as long as it is unique, and retains the information that is in the higher row number. While the code I shared works, it is too slow for a large data set.
Another fast method, is to use the Dictionary object. You can check if any of the values in Column A already exists in the Dictionary. If they do (meaning it's a duplicate), then don't delete them every time, this adds a long time for code's run-time. Instead, you can use a DelRng object, which is a Range that uses Union to merge multiple rows that are duplicates.
Later on, you can delete the entire ducplicates range at once by using DelRng.Delete.
Code
Option Explicit
Sub RemoveDuplicatesUsingDict()
Dim wb_DST As Workbook
Dim sWs_DST As String
' Dictionary variables
Dim Dict As Object
Dim DictIndex As Long, ExistIndex As Long
Dim DelRng As Range
Dim LastRow As Long, i As Long
' --- parameters for my internal testing ---
Set wb_DST = ThisWorkbook
sWs_DST = "Sheet1"
Application.ScreenUpdating = False
Set Dict = CreateObject("Scripting.Dictionary")
With wb_DST.Sheets(sWs_DST)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column "A"
For i = LastRow To 2 Step -1
If Not Dict.exists(.Range("A" & i).Value) Then ' value doesn't exists yet in Dictionary >> add this Key
Dict.Add .Range("A" & i).Value, .Range("A" & i).Value
Else ' value already exists in Dictionary >> add it to DelRng (later will delete the entire range)
If Not DelRng Is Nothing Then
Set DelRng = Application.Union(DelRng, .Rows(i)) ' add current row to existing DelRng
Else
Set DelRng = .Rows(i)
End If
End If
Next i
End With
' delete the entire range at 1-shot
If Not DelRng Is Nothing Then DelRng.Delete
Application.ScreenUpdating = True
End Sub
Fast use of data field array
Looping through a range isn't that fast - you can speed it up considerably if you create a data field array with your search data (array = needed range in column "A" - see 1) and loop therein. If your data set grows, this gets even faster in comparison to the above shown dictionary approach, though it rests a good and reliable method.
Search Method
Any array value is checked against a concatenated search string with already found unique values and added if not yet included - see 2)
The completed string is transformed to an array and written back to a given target column (e.g. "H") - see 3) and 4)
I even added a second column with the corresponding row numbers, so you should be in the position to use them for further action. You could write results to another sheet, too.
Code - method demo
Sub RemoveDuplicates()
Dim t As Double: t = Timer ' stop watch
Dim ws As Worksheet ' source sheet (object)
Dim i As Long ' row index
Dim a, arr, arr2 ' variant
Dim s As String, si As String
Const SEP = "|" ' delimiter
s = SEP: si = SEP
' 0) fully qualified range reference to source sheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
' 1) write column A data to one based 2-dim data field array
a = ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
' 2) loop through data and check for duplicates in concatenated string s
For i = 2 To UBound(a)
If InStr(s, SEP & a(i, 1) & SEP) = 0 Then
If Len(a(i, 1)) > 0 Then
s = s & a(i, 1) & SEP
si = si & i & SEP
End If
End If
Next i
' 3) transform unique values to zero based 1-dim array
arr = Split(Mid(s, 2), SEP) ' duplicates string to array
arr2 = Split(Mid(si, 2), SEP) ' found row numbers
' 4) write result to column H2:H... ' <<< change target to wanted column
ws.Range("H:H").ClearContents '
ws.Range("H2:H" & (2 + UBound(arr))).Value = Application.Transpose(arr)
ws.Range("I2:I" & (2 + UBound(arr2))).Value = Application.Transpose(arr2)
Debug.Print UBound(arr) + 0 & " unique items found", Format(Timer - t, "0.00 seconds needed")
End Sub
=================================================================
EDIT
Version 2 -- includes overwriting original data with unique values
Here you find a slightly modified version overwriting the original data in 35 columns (A2:AI..) with unique values.
Sub RemoveDuplicates2()
' Edit: overwrite original data A2:AI{..} with unique values
Dim t As Double: t = Timer ' stop watch
Dim ws As Worksheet ' source sheet (object)
Dim i As Long ' row index
Dim a, arr, arr2 ' variant
Dim s As String, si As String
Const SEP = "|" ' delimiter
Const MyLastColumn = "AI" ' letter of last column (no 35) = "AI"
s = SEP: si = SEP
' fully qualified range reference to source sheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
' write column A data to one based 2-dim data field array
a = ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
' loop through data and check for duplicates in concatenated string s
For i = 2 To UBound(a) ' For i = UBound(a) To 2 Step -1
If InStr(s, SEP & a(i, 1) & SEP) = 0 Then
If Len(Trim(a(i, 1))) > 0 Then
s = s & a(i, 1) & SEP
si = si & i & SEP
End If
End If
Next i
' write unique values to zero based 1-dim array (starts with index 0; last delimiter removed in this version)
arr2 = Split(Mid(si, 2, Len(si) - 2), SEP) ' found row numbers
' overwrite original data
For i = LBound(arr2) To UBound(arr2) ' starts with index 0!
s = "A" & arr2(i) & ":" & MyLastColumn & arr2(i)
arr = ws.Range(s) ' create 1-based 1-line (2-dim) array
s = "A" & i + 2 & ":" & MyLastColumn & i + 2 ' 0 + 2 = +2 ... start in row 2
ws.Range(s) = arr ' write back unique row values
Next i
s = "A" & UBound(arr2) + 3 & ":" & MyLastColumn & UBound(a) + 1
ws.Range(s).ClearContents ' clear rest of original data
Debug.Print UBound(arr2) + 1 & " unique items found", Format(Timer - t, "0.00 seconds needed") ' result
End Sub
So at Assign sheet I indicate the sheets to take data for each group (each for column and the first row is the explanation of the group). I dynamically can add res at the file or delete
After I use predefined codes to assign which type of discounts / day are applied. At the example I only put two codes (C and S) and one week. For example the raw sheet data for designations Red and Black.
Data product worksheet
Then at Diary I want to show the result of concatenate the B1 value (name of product) each time code fromm price are indicated into the rows. Also I use two loop because at raw product data I have one column for price but at the Diary I have two
Summary page
This is what I finally want to get and doing like that because my boss don't know anything for code and he wan't edite it so I try to do ll dynamic at the sheets :) [I only put two images because i don't have reputations point enough to put more]
With the formula I only get FALSE as answer :(, and I need to get what you can see at summary page
Sub Diary()
Dim I As Integer, x As Integer, y As Integer, z As Integer, n As Integer
Dim p As Integer, d As Integer, f As Integer
Dim a As String, b As String
Dim element As Variant
' Initialize variables I and y at 3 and 4 to begin to show the data at the column I desire. Also x and z were intended to pass the one column mode data sheet to the two column mode at the summary page.
I = 3
x = 1
y = 4
z = 0
With Worksheets("Asign")
.Activate
.Range("B2").Select
End With
' Set the size of Data with sheet names it get form the page assign. It can dynamically changed as size as names of sheets
With ActiveSheet
r = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
Dim Data() As String
ReDim Data(r)
For p = 1 To r - 1
Data(p) = ActiveSheet.Cells(p + 1, "B").Value
Next p
With Worksheets("Diary")
.Activate
.Range("C7").Select
End With
' At Diary concatenate the same cell for all the sheets I have his name stored at Data() and then pass to the next cell with data at raw data sheets (in the images (Red, Black ,... pages). In this case search for code S
Do
Cells(7, I).Select
ActiveCell.Value = ActiveCell.FormulaR1C1 = "=CONCATENATE(" & a & ")"
For Each element In Data
b = ActiveCell.FormulaR1C1 = "IF(Data& !R[-2]C[" & x & "]=""S"",CONCATENATE(Data&!R1C2,"", ""),"""")"
a = b & ";" & b
Next element
x = x - 1
I = I + 2
Loop While I < 4
' The same for the second column of summary sheet called Diary. In this case search for code C
Do
Cells(7, y).Select
ActiveCell.Value = ActiveCell.FormulaR1C1 = _
"=CONCATENATE(" & a & ")"
For Each element In Data
b = ActiveCell.FormulaR1C1 = "IF(Data& !R[-2]C[" & z & "]=""S"",CONCATENATE(Data&!R1C2,"", ""),"""")"
a = b & ";" & b
Next element
z = z - 1
y = y + 2
Loop While I < 4
' Drag and Drop the formula to all the sheet's cells you need
Range("C8:E8").Select
Selection.AutoFill Destination:=Range("C8:E10"), Type:=xlFillDefault
'
End Sub
try this. .... could be simplified by looping through "colors" .... black, red, etc
Sub Diary()
Dim red As Variant
red = Sheets("red").Range("d6:g12") ' put range data into an array for processing
Dim black As Variant
black = Sheets("black").Range("d6:g12")
Dim i As Integer
Dim j As Integer
Dim strC As String
Dim strS As String
For i = 1 To 7
For j = 1 To 4
strC = ""
strS = ""
If LCase(black(i, j)) = "c" Then strC = "Black"
If LCase(black(i, j)) = "s" Then strS = "Black"
If LCase(red(i, j)) = "c" Then
If Len(strC) > 1 Then strC = strC & ";"
strC = strC & "Red"
End If
If LCase(red(i, j)) = "s" Then
If Len(strS) > 1 Then strS = strS & ";"
strS = strS & "Red"
End If
Sheets("diary").Range("c7").Cells(i, j * 2 - 1) = strS
Sheets("diary").Range("c7").Cells(i, j * 2) = strC
Next j
Next i
End Sub
I am looping through each cell in a column and performing split operation on the text(delimited by ,) for each cell. I have the result in an array.And I am placing it in a range of cells.When ever next cell value is fetched and split operation is carried , new value overwrites the previous result. How can i find the next empty cell and place the array content with out overwriting.
Range("A1:A" & UBound(x) + 1) = WorksheetFunction.Transpose(x)
I have texts separated by ,
example A,B,C,D in column E2
B,M,C... in E3 and so on till 36000(value may increase)
Dim txt As String
Dim x As Variant
Dim i As Long
Dim lrow As Double
lrow = Sheet1.UsedRange.Rows.Count
For j = 1 To lrow
txt = Sheet1.Range("m2").Offset(j - 1, 0)
x = Split(txt, ",")
For i = 0 To UBound(x)
'Debug.Print x(i)
Range("A1:A" & UBound(x) + 1) = WorksheetFunction.Transpose(x) 'How can i change this line to find next empty cell and palce the result in it
Next i
Next j
The above code will loop through each row and split the text. But every time the result is overwritten. How can i find next empty cell and place the result in it?
Please try this, This will work for M2=abc,BCD,Xyz,pdt. If M3=zse,ssd,vbd will come it will over write the value A1 to A(j) Value. So update it accordingly.
Dim i As Integer
Dim M2 As String
Dim spltStore As Variant
Public Sub page_load()
M2="abc,BCD,Xyz,pdt"
spltStore = Split(M2, ",")
j = 1
For i = 0 To UBound(spltStore)
Sheet1.Range("A" & j).Value = spltStore(i)
Debug.Print spltStore(i)
j = j + 1
Next i
End Sub
Hope this will work for you.
Try this:
j=1
i=1
Do While IsEmpty(Worksheets("test").Cells(j, i)) = False
'<do your stuff>
j = j + 1
Loop
j and i are cell coordinates. This loop will go through all the non-empty cells and stop on an empty one.