I want to copy some texts from a sheet to another. For example: 01/02/2021 .
However VBA automatically convert it to 2020/01/02. How can I stop it?
The following codes didn't work.
Example1:
sheet_1.Range("A1:A" & sheet1.Cells(1, 1).CurrentRegion.End(xlDown).row).Copy
ws.Range("start").PasteSpecial xlPasteValues
ws.Range("start").PasteSpecial xlPasteFormats
Example2:
sheet_1.Range("A1:A" & sheet1.Cells(1, 1).CurrentRegion.End(xlDown).row).Copy
ws.Range("start").PasteSpecial xlPasteFormulasAndNumberFormats
Example3:
sheet_1.Range("A1:A" & sheet1.Cells(1, 1).CurrentRegion.End(xlDown).row).Copy
ws.Range("start").Paste xlPaste Format:="Text" 'This causes an error
Please, try the next code. It will extract the date from the (pseudo) xls file and place it in the first column of the active sheet. Correctly formatted as date:
Sub openXLSAsTextExtractDate()
Dim sh As Worksheet, arrTXT, arrLine, arrD, arrDate, fileToOpen As String, i As Long, k As Long
Set sh = ActiveSheet 'use here the sheet you need
fileToOpen = "xls file full name" 'use here the full name of the saved xls file
'put the file content in an array splitting the read text by end of line (vbCrLf):
arrTXT = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(fileToOpen, 1).ReadAll, vbCrLf)
ReDim arrDate(UBound(arrTXT)) 'redim the array where the date will be kept, to have enough space for all the date values
For i = 39 To UBound(arrTXT) - 1 'iterate between the array elements, starting from the row where date data starts
arrLine = Split(arrTXT(i), vbTab) 'split the line by vbTab
arrD = Split(arrLine(0), "/") 'split the first line element (the date) by "/"
arrDate(k) = DateSerial(arrD(2), arrD(1), arrD(0)): k = k + 1 'properely format as date and fill the arrDate elements
Next i
ReDim Preserve arrDate(k - 1) 'keep only the array elements keeping data
With sh.Range("A1").Resize(UBound(arrDate) + 1, 1)
.value = Application.Transpose(arrDate) 'drop the array content
.NumberFormat = "dd/mm/yyyy" 'format the column where the date have been dropped
End With
End Sub
Edited:
You did not say anything...
So, I made a code returning the whole table (in the active sheet). Please, test it. It will take only some seconds:
Sub openXLSAsText()
Dim sh As Worksheet, arrTXT, arrLine, arrD, arrData, fileToOpen As String, i As Long, j As Long, k As Long
Set sh = ActiveSheet 'use here the sheet you need
fileToOpen = "xls file full name" 'use here the full name of the saved xls file
'put the file content in an array splitting the read text by end of line (vbCrLf):
arrTXT = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(fileToOpen, 1).ReadAll, vbCrLf)
ReDim arrData(1 To 10, 1 To UBound(arrTXT)) 'redim the array where the date will be kept, to have enough space for all the date values
For i = 38 To UBound(arrTXT) - 1 'iterate between the array elements, starting from the row where table header starts
arrLine = Split(arrTXT(i), vbTab) 'split the line by vbTab
k = k + 1 'increment the k variable (which will become the table row)
For j = 0 To 9
If j = 0 And k > 1 Then
arrD = Split(arrLine(j), "/") 'split the first line element (the date) by "/"
arrData(j + 1, k) = DateSerial(arrD(2), arrD(1), arrD(0)) 'propperely format as date and fill the arrDate elements
ElseIf j = 2 Or j = 3 Then
arrData(j + 1, k) = Replace(arrLine(j), ",", ".") 'correct the format for columns 3 and four (replace comma with dot)
Else
arrData(j + 1, k) = arrLine(j) 'put the rest of the column, not processed...
End If
Next j
Next i
ReDim Preserve arrData(1 To 10, 1 To k) 'keep only the array elements with data
With sh.Range("A1").Resize(UBound(arrData, 2), UBound(arrData))
.value = Application.Transpose(arrData) 'drop the array content
.EntireColumn.AutoFit 'autofit columns
.Columns(1).NumberFormat = "dd/mm/yyyy" 'format the first column
End With
MsgBox "Ready..."
End Sub
Related
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
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
I'm trying to figure out how to split rows of data where columns B,C,D in the row contain multiple lines and others do not. I've figured out how to split the multi-line cells if I copy just those columns into a new sheet, manually insert rows, and then run the macro below (that's just for column A), but I'm lost at coding the rest.
Here's what the data looks like:
So for row 2, I need it split into 6 rows (one for each line in cell B2) with the text in cell A2 in A2:A8. I also need columns C and D split the same as B, and then columns E:CP the same as column A.
Here is the code I have for splitting the cells in columns B,C,D:
Dim iPtr As Integer
Dim iBreak As Integer
Dim myVar As Integer
Dim strTemp As String
Dim iRow As Integer
iRow = 0
For iPtr = 1 To Cells(Rows.Count, col).End(xlUp).Row
strTemp = Cells(iPtr1, 1)
iBreak = InStr(strTemp, vbLf)
Range("C1").Value = iBreak
Do Until iBreak = 0
If Len(Trim(Left(strTemp, iBreak - 1))) > 0 Then
iRow = iRow + 1
Cells(iRow, 2) = Left(strTemp, iBreak - 1)
End If
strTemp = Mid(strTemp, iBreak + 1)
iBreak = InStr(strTemp, vbLf)
Loop
If Len(Trim(strTemp)) > 0 Then
iRow = iRow + 1
Cells(iRow, 2) = strTemp
End If
Next iPtr
End Sub
Here is a link to an example file (note this file has 4 rows, the actual sheet has over 600): https://www.dropbox.com/s/46j9ks9q43gwzo4/Example%20Data.xlsx?dl=0
This is a fairly interesting question and something I have seen variations of before. I went ahead and wrote up a general solution for it since it seems like a useful bit of code to keep for myself.
There are pretty much only two assumptions I make about the data:
Returns are represented by Chr(10) or which is the vbLf constant.
Data that belongs with a lower row has enough returns in it to make it line up. This appears to be your case since there are return characters which appear to make things line up like you want.
Pictures of the output, zoomed out to show all the data for A:D. Note that the code below processes all of the columns by default and outputs to a new sheet. You can limit the columns if you want, but it was too tempting to make it general.
Code
Sub SplitByRowsAndFillBlanks()
'process the whole sheet, could be
'Intersect(Range("B:D"), ActiveSheet.UsedRange)
'if you just want those columns
Dim rng_all_data As Range
Set rng_all_data = Range("A1").CurrentRegion
Dim int_row As Integer
int_row = 0
'create new sheet for output
Dim sht_out As Worksheet
Set sht_out = Worksheets.Add
Dim rng_row As Range
For Each rng_row In rng_all_data.Rows
Dim int_col As Integer
int_col = 0
Dim int_max_splits As Integer
int_max_splits = 0
Dim rng_col As Range
For Each rng_col In rng_row.Columns
'splits for current column
Dim col_parts As Variant
col_parts = Split(rng_col, vbLf)
'check if new max row count
If UBound(col_parts) > int_max_splits Then
int_max_splits = UBound(col_parts)
End If
'fill the data into the new sheet, tranpose row array to columns
sht_out.Range("A1").Offset(int_row, int_col).Resize(UBound(col_parts) + 1) = Application.Transpose(col_parts)
int_col = int_col + 1
Next
'max sure new rows added for total length
int_row = int_row + int_max_splits + 1
Next
'go through all blank cells and fill with value from above
Dim rng_blank As Range
For Each rng_blank In sht_out.Cells.SpecialCells(xlCellTypeBlanks)
rng_blank = rng_blank.End(xlUp)
Next
End Sub
How it works
There are comments within the code to highlight what is going on. Here is a high level overview:
Overall, we iterate through each row of the data, processing all of the columns individually.
The text of the current cell is Split using the vbLf. This gives an array of all the individual lines.
A counter is tracking the maximum number of rows that were added (really this is rows-1 since these arrays are 0-indexed.
Now the data can be output to the new sheet. This is easy because we can just dump the array that Split created for us. The only tricky part is getting it to the right spot on the sheet. To that end, there is a counter for the current column offset and a global counter to determine how many total rows need to be offset. The Offset moves us to the right cell; the Resize ensures that all of the rows are output. Finally, Application.Transpose is needed because Split returns a row array and we're dumping a column.
Update the counters. Column offset is incremented every time. The row offset is updated to add enough rows to cover the last maximum (+1 since this is 0-indexed)
Finally, I get to use my waterfall fill (your previous question) on all of the blanks cells that were created to ensure no blanks. I forgo error checking because I assume blanks exist.
Thank you for providing a sample. This task was so interesting that I thought of writing the code for that. You are more than welcome to tweak it to your satisfaction, and I hope your team gets to use an RDBMS to manage this kind of data in the future.
Sub OrganizeSheet()
Dim LastRow As Integer
LastRow = GetLastRow()
Dim Barray() As String
Dim Carray() As String
Dim Darray() As String
Dim LongestArray As Integer
Dim TempInt As Integer
Dim i As Integer
i = 1
Do While i <= LastRow
Barray = Split(Range("B" & i), Chr(10))
Carray = Split(Range("C" & i), Chr(10))
Darray = Split(Range("D" & i), Chr(10))
LongestArray = GetLongestArray(Barray, Carray, Darray)
If LongestArray > 0 Then
' reset the values of B, C and D columns
On Error Resume Next
Range("B" & i).Value = Barray(0)
Range("C" & i).Value = Carray(0)
Range("D" & i).Value = Darray(0)
Err.Clear
On Error GoTo 0
' duplicate the row multiple times
For TempInt = 1 To LongestArray
Rows(i & ":" & i).Select
Selection.Copy
Range(i + TempInt & ":" & i + TempInt).Select
Selection.Insert Shift:=xlDown
' as each row is copied, change the values of B, C and D columns
On Error Resume Next
Range("B" & i + TempInt).Value = Barray(TempInt)
If Err.Number > 0 Then Range("B" & i + TempInt).Value = ""
Err.Clear
Range("C" & i + TempInt).Value = Carray(TempInt)
If Err.Number > 0 Then Range("C" & i + TempInt).Value = ""
Err.Clear
Range("D" & i + TempInt).Value = Darray(TempInt)
If Err.Number > 0 Then Range("D" & i + TempInt).Value = ""
Err.Clear
On Error GoTo 0
Application.CutCopyMode = False
Next TempInt
' increment the outer FOR loop's counters
LastRow = LastRow + LongestArray
i = i + LongestArray
End If
i = i + 1
Loop
End Sub
' ----------------------------------
Function GetLongestArray(ByRef Barray() As String, ByRef Carray() As String, ByRef Darray() As String)
GetLongestArray = UBound(Barray)
If UBound(Carray) > GetLongestArray Then GetLongestArray = UBound(Carray)
If UBound(Darray) > GetLongestArray Then GetLongestArray = UBound(Darray)
End Function
' ----------------------------------
Function GetLastRow() As Integer
Worksheets(1).Select
Range("A1").Select
Selection.End(xlDown).Select
GetLastRow = Selection.Row
Range("A1").Select
End Function
Give it a shot!
I'm working on a 5 sheet workbook, where a button named ExportCSV on sheet 5 exports data on sheet 3. More specifically, the button runs a VBA code that goes row by row and checks the first 3 cells for data. If any of the first three cells have data, then the whole row is selected. After all rows with data are selected, the data is written row by row to a CSV file (the file itself is semicolon-delimited, however).
The problem that I'm having is that some cell formatting is being copied over, but some is not. For example, values in cells formatted for Accounting with a $ are formatted correctly, meaning "$12,345,678.90" shows up as "$12,345,678.90." However, values in cells formatted as Accounting but without $ are not being written to the csv correctly, meaning "12,345,678.90" is being written as "12345678.9."
Below is the Macro in question.
Dim planSheet As Worksheet
Dim temSheet As Worksheet
Private Sub ExportCSV_Click()
Dim i As Integer
Dim j As Integer
Dim lColumn As Long
Dim intResult As Integer
Dim strPath As String
On Error GoTo Errhandler
Set temSheet = Worksheets(3)
i = 2
Do While i < 1001
j = 1
Do While j < 4
If Not IsEmpty(temSheet.Cells(i, j)) Then
temSheet.Select
lColumn = temSheet.Cells(2, Columns.Count).End(xlToLeft).Column
temSheet.Range(temSheet.Cells(2, 1), temSheet.Cells(i, lColumn)).Select
End If
j = j + 1
Loop
i = i + 1
Loop
Application.FileDialog(msoFileDialogFolderPicker).InitialFileName = Application.ActiveWorkbook.Path
Application.FileDialog(msoFileDialogFolderPicker).Title = "Select a Path"
Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Select Path"
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
If intResult <> 0 Then
'dispaly message box
strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
End If
Dim X As Long, FF As Long, S() As String
ReDim S(1 To Selection.Rows.Count)
For X = 1 To Selection.Rows.Count
S(X) = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(Selection.Rows(X).Value)), ";")
Next
FF = FreeFile
FilePath = strPath & "\Data" & Format(Now(), "yyyyMMddhhmmss") & ".csv"
Open FilePath For Output As #FF
Print #FF, Join(S, vbNewLine)
Close #FF
Errhandler:
...Error Handling Code omitted
End Sub
I need to be able to copy over the exact formatting of the cells. Converting the no-$ cells to $ cells won't work because the values without $ are being used for a calculation later on in the process that can handle the commas, but not a $, and I can't change the code for the later calculation (proprietary plug-in doing the calculation.) Also, the rows have mixed content, meaning some values in the row are text instead of numbers.
I ended up following David Zemens' advice and overhauled the section that was For X = 1 to Selection.Rows.Count See below.
For X = 1 To Selection.Rows.Count
For Y = 1 To Selection.Columns.Count
If Y <> Selection.Columns.Count Then
If IsNumeric(temSheet.Cells(X + 1, Y).Value) Then
If temSheet.Cells(X + 1, Y).Value = 0 Then
S(X) = S(X) & ";"
Else
S(X) = S(X) & Replace(temSheet.Cells(X + 1, Y).Text, " ", "") & ";"
End If
Else
S(X) = S(X) & Trim(temSheet.Cells(X + 1, Y).Text) & ";"
End If
Else
If IsNumeric(temSheet.Cells(X + 1, Y).Value) Then
If temSheet.Cells(X + 1, Y).Value <> 0 Then
S(X) = S(X) & Replace(temSheet.Cells(X + 1, Y).Text, " ", "")
End If
Else
S(X) = S(X) & Trim(temSheet.Cells(X + 1, Y).Text)
End If
End If
Next
Next
Some more formatting was necessary. It goes cell by cell, purposefully skipping the first row of the sheet. The .Text property of some of the cells returned empty space before the value or between the $ and value, so it had to be removed. Trim removes leading and ending spaces while Replace replaces all spaces in the export.
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.