I am trying to split these names up so that are in a cell each. I have tried text to columns and that doesn't do the job.
you can use the code below to split the string by chr(10), which presents a line feed character. Please note the assumption behind input data header and output column. Please also note that dictionary works in this case only because dictionaries in VBA somehow maintains ordering - this is unlikely to be the case in other programming languages.
Public Sub sub_test()
Dim wsThis As Worksheet: Set wsThis = ActiveSheet
Dim vData As Variant
Dim dicOutput As Object: Set dicOutput = CreateObject("scripting.dictionary")
Dim vTemp As Variant
Dim vLine As Variant
Dim i As Long
With wsThis
' Read data into memory - assume no header
vData = .Range(.Range("A1"), .Range("A1").End(xlDown))
' Loop through each row
For i = LBound(vData, 1) To UBound(vData, 1)
' Split by new line
vTemp = Split(vData(i, 1), Chr(10))
For Each vLine In vTemp
' Check if new line is empty string
If Trim(vLine) <> vbNullString Then
dicOutput(vLine) = 1
End If
Next vLine
Next i
vTemp = Application.Transpose(dicOutput.keys)
' Output into worksheet - assume column C
.Range("C1").Resize(UBound(vTemp, 1) - LBound(vTemp, 1) + 1, UBound(vTemp, 2) - LBound(vTemp, 2) + 1) = vTemp
End With
End Sub
Related
I want to remove the left character from a column of strings without looping over each cell, but I'm getting an error in Excel. Here is my code, can I do this without a for loop?
Public Sub TestRngAdjust()
Dim TestRNG As Range
Set TestRNG = Range("A1:A5")
TestRNG.NumberFormat = "#"
TestRNG.Value = Right(TestRNG.Value, Len(TestRNG.Value) - 1)
End Sub
If you don't want to loop:
Dim s As String
s = "RIGHT(" & TestRNG.Address & ",LEN(" & TestRNG.Address & ") - 1)"
TestRNG.Value = TestRNG.Parent.Evaluate(s)
But really, it's very easy to read the data into a Variant array, use Right on each element, then write the array back to the range.
Loops are not bad. They are bad when looping ranges on worksheets.
Use variant arrays to loop.
Using Variant method:
load range into a variant array.
loop the array and make changes.
assign variant array data back to range.
Public Sub TestRngAdjust()
Dim TestRNG As Range
Set TestRNG = Range("A1:A5")
Dim rngarr As Variant
rngarr = TestRNG.Value
Dim i As Long
For i = 1 To UBound(rngarr, 1)
rngarr(i, 1) = Mid$(rngarr(i, 1), 2)
Next i
TestRNG.NumberFormat = "#"
TestRNG.Value = rngarr
End Sub
I have a column of Excel cells that follow this format (the random strings are not in a fixed order). Strings that don't start with a certain string need to be removed.
randomstringA text_that_needs_to_be_kept1
text_that_needs_to_be_removed1
randomstringB text_that_needs_to_be_kept2
randomstringA text_that_needs_to_be_kept3
text_that_needs_to_be_removed2
I want the cell's output to be this (linebreak must be kept):
text_that_needs_to_be_kept1
text_that_needs_to_be_kept2
text_that_needs_to_be_kept3
And not this (linebreak got removed):
text_that_needs_to_be_kept1
text_that_needs_to_be_kept2
text_that_needs_to_be_kept3
The following code will go down column A starting in row 1 and remove any line that doesn't start with a value from the array arrToKeep, keeping the linebreaks.
Option Explicit
Sub RemoveStrings()
Dim rngData As Range
Dim arrData As Variant
Dim arrLines As Variant
Dim arrToKeep As Variant
Dim idx1 As Long
Dim idx2 As Long
Dim idxRow As Long
Dim boolKeep As Boolean
arrToKeep = Array("randomstringA", "randomstringB")
Set rngData = Range("A1", Range("A" & Rows.Count).End(xlUp))
arrData = rngData.Value
For idxRow = LBound(arrData, 1) To UBound(arrData, 1)
arrLines = Split(arrData(idxRow, 1), vbLf)
For idx1 = LBound(arrLines) To UBound(arrLines)
boolKeep = False
For idx2 = LBound(arrToKeep) To UBound(arrToKeep)
If arrLines(idx1) Like arrToKeep(idx2) & "*" Then
boolKeep = True
Exit For
End If
Next idx2
If Not boolKeep Then
arrLines(idx1) = ""
End If
Next idx1
arrData(idxRow, 1) = Join(arrLines, vbLf)
Next idxRow
rngData.Value = arrData
End Sub
In B1 place this formula =IF(LEFT(A1;1)="r";MID(A1;FIND(" ";A1;1)+1;500);"") and copy+paste to the other cells in column B.
There are 24 sheets in this workbook. I need to copy the same range from 23 sheets and paste them in a final sheet called "ALL SURVEY". Is there any way to code it in such a way that I don't need to write so much code as I did in the following macro?
Sheets("2").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E2").*PasteSpecial xlPasteValues*
Sheets("3").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E3").*PasteSpecial xlPasteValues*
Sheets("4").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E4").*PasteSpecial xlPasteValues*
Sheets("5").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E5").*PasteSpecial xlPasteValues*
It will be much appreciated if you help me get through this hard task
Thank you
You can use a For...Next loop for this:
Sub Tester()
Dim n As Long, c As Range
Set c = ThisWorkbook.Sheets("ALL SURVEY").Range("E2") 'first destination cell
'loop through sheets
For n = 2 To 23
'convert n to string to get the correct sheet
' Sheets("2") vs Sheets(2) - by sheet Name vs. Index
With ThisWorkbook.Sheets(CStr(n)).Range("U3:X3")
c.Resize(.Rows.Count, .Columns.Count).Value = .Value 'set values
Set c = c.Offset(1, 0) 'next destination
End With
Next n
End Sub
You can do something like this:
Sub copyPaste()
Dim survey_sheet As Worksheet, count As Long
count = 1 'start pasting from this row
For Each survey_sheet In ThisWorkbook.Sheets
If survey_sheet.Name <> "ALL SURVEY" Then
survey_sheet.Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E" & count).PasteSpecial xlPasteValues
count = count + 1
End If
Next survey_sheet
End Sub
As you can see in the macro above, there is a loop For all the sheets in the Workbook. It will end when it has gone through every single one.
The If statement is to avoid copy/pasting in the final sheet ant the count variable is for pasting in the next empty row on "ALL SURVEY" sheet.
Copy Ranges by Rows
Adjust the values in the constants section. Pay attention to the Exceptions List. I added those two 'funny' names just to show that you have to separate them by the Delimiter with no spaces. The list can contain non-existing worksheet names, but it won't help, so remove them and add others if necessary.
You can resize the 'copy' range as you desire (e.g. U3:X5, Z7:AS13). The result will be each next range below the other (by rows).
Basically, the code will loop through all worksheets whose names are not in the Exceptions List and will write the values of the given range to 2D one-based arrays in an Array List. Then it will loop through the arrays of the Array List and copy the values to the resulting Data Array whose values will then be copied to the Destination Range.
The Code
Option Explicit
Sub copyByRows()
Const dstName As String = "ALL SURVEY"
Const dstFirst As String = "E2"
Const srcRange As String = "U3:X3"
Const Delimiter As String = ","
Dim ExceptionsList As String
ExceptionsList = dstName & Delimiter & "Sheet500,Sheet1000"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim dst As Worksheet: Set dst = wb.Worksheets(dstName)
Dim srCount As Long: srCount = dst.Range(srcRange).Rows.Count
Dim cCount As Long: cCount = dst.Range(srcRange).Columns.Count
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
Dim Exceptions() As String: Exceptions = Split(ExceptionsList, Delimiter)
Dim ws As Worksheet
For Each ws In wb.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
arl.Add ws.Range(srcRange).Value
End If
Next ws
Dim Data As Variant: ReDim Data(1 To arl.Count * srCount, 1 To cCount)
Dim Item As Variant
Dim i As Long
Dim j As Long
Dim k As Long
For Each Item In arl
For i = 1 To srCount
k = k + 1
For j = 1 To cCount
Data(k, j) = Item(i, j)
Next j
Next i
Next Item
dst.Range(dstFirst).Resize(k, cCount).Value = Data
End Sub
Currently I have a template which is in range called rngP1.
And this contains a text below:
"This is to confirm that strTitle has been enacted on strDate for strCompany."
Basically, I have a data in another sheet that will be used to replace these 3 strings from my template:
So what I would like to happen is that in every row data it will search strings strTitle, strDate, and strCompany and replace them according to the data of each row.
I have a code already, however, it doesn't work as I expected:
Sub example()
Dim wsMain As Worksheet
Set wsMain = Sheets("Main")
Dim wsTemplate As Worksheet
Set wsTemplate = Sheets("Template")
Dim textToReplace As Variant
Dim array_example()
Dim Find_Text As Variant
Dim str As String
last_row = wsMain.Range("A1").End(xlDown).Row 'Last row of the data set
ReDim array_example(last_row - 1, 2)
Find_Text = Array("strTitle", "strDate", "strCompany")
str = wsTemplate.Range("rngP1").Value
'Storing values in the array
For i = 0 To last_row - 1
array_example(i, 0) = wsMain.Range("A" & i + 2)
array_example(i, 1) = wsMain.Range("C" & i + 2)
array_example(i, 2) = wsMain.Range("D" & i + 2)
Next
For i = LBound(array_example, 1) To UBound(array_example, 1)
For j = LBound(array_example, 2) To UBound(array_example, 2)
For a = 0 To UBound(Find_Text)
str = Replace(str, Find_Text(a), array_example(i, j))
Next a
Next j
MsgBox str
Next i
End Sub
Wrong Output:
It should be:
This is to confirm that Title1 has been enacted on 13-October-18 for Company X.
And next one would be the next row which is title 2. So on and so fort.
If you have an alternative way to do it, I appreciate it.
Here is a working example:
You can push the data range from a worksheet into an array with one line without looping
DataArr = wsMain.Range("A2:D" & LastRow).Value
You need only 2 loops for the replacing:
one to loop through the data rows
one to loop through the variables to replace
Your template str was not initialized within the loop, but you need a fresh template for every data row.
Note that the array loaded from the range starts counting from 1 but the variables array starts counting from 0.
Option Explicit
Sub Example()
Dim Template As String
Template = "This is to confirm that strTitle has been enacted on strDate for strCompany."
'load your template string from worksheet here!
Dim Variables As Variant 'variables to be replaced
Variables = Array("strTitle", "strDate", "strCompany")
Dim wsMain As Worksheet
Set wsMain = ThisWorkbook.Worksheets("Main")
Dim LastRow As Long 'this method is more reliable to find the last used row
LastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
Dim DataArr As Variant 'load the complete data range into an array
DataArr = wsMain.Range("A2:D" & LastRow).Value
Dim Output As String
Dim iRow As Long, iVar As Long
For iRow = LBound(DataArr, 1) To UBound(DataArr, 1) '1 to LastRow
Output = Template 'initialize with the template!
For iVar = LBound(Variables) To UBound(Variables) ' 0 to 2
Output = Replace(Output, Variables(iVar), DataArr(iRow, iVar + 1))
Next iVar
Debug.Print Output
Next iRow
End Sub
I currently have a script (hobbled together from SO), that compares two documents (50 columns x 1600 rows) and creates a new document containing the discrepancies.
Often the same discrepancy will be duplicated many (every) time due to it being an expected conversion.
Is there anyway to refine the output of the script?
Right now it just out puts the First column of worksheetA, plus the related discrepancy fields/cells.
I was sort of envisioning a roll up and total if there are duplicate of the same expected error to make the unexpected errors more visible.
Thank you so much in advance for any advice:
'Look for the [] and replace
'So [User] = yourusername
'And [Worksheetname] = yourworksheetname
' etc
Option Compare Text
Sub CompareWorkbooks()
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
nlin = 1
ncol = 1
'Get the worksheets from the workbooks
Set wbkA = Workbooks.Open(Filename:="C:\Users\[User]\[Path]\[Workbookname].xlsm") ' or whatever workbook path
Set varSheetA = wbkA.Worksheets("[WorksheetName]") ' or whatever sheet you need
Set wbkB = Workbooks.Open(Filename:="C:\Users\[User]\[Path]\[Workbookname].xlsm")
Set varSheetB = wbkB.Worksheets("Sheet1") ' or whatever sheet you need
Set wbkC = Workbooks.Open(Filename:="C:\Users\[User]\[Path]\[Workbookname].xlsm")
strRangeToCheck = "A2:BX2000" ' If you know the data will only be in a smaller range, reduce the size of the ranges above.
Debug.Print Now
varSheetA = wbkA.Worksheets("[WorksheetName]").Range(strRangeToCheck)
varSheetB = wbkB.Worksheets("[WorksheetName]").Range(strRangeToCheck) ' or whatever your other sheet is.
Debug.Print Now
For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
If varSheetA(iRow, iCol) = varSheetB(iRow, iCol) Then
' Cells are identical.
' Do nothing.
Else
' Cells are different. Let's fill our main template with the information
Workbooks("New.xlsm").Activate
Cells(nlin, ncol) = varSheetA(iRow, 1) 'Gives the AID of the related changed field
Cells(nlin, ncol + 1) = varSheetA(iRow, iCol) 'Gives me the value in workbookA
Cells(nlin, ncol + 2) = varSheetB(iRow, iCol) 'Gives me the value in workbookB
nlin = nlin + 1
End If
Next
Next
End Sub