Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 6 days ago.
Improve this question
I just want to modify the vba code below a bit.
Please recommend the solution
Thanks
Sub GetFileNametest()
Dim Rng As Range
Dim arr1() As String
Dim arr2() As String
Dim arr3() As String
Dim s As String
Application.ScreenUpdating = False
' Find last row in column A with data
Sheets("Master").Select
lr = Cells(Rows.Count, "A").End(xlUp).Row
' Pre-format column C for text
Columns("C:C").NumberFormat = "#"
' Loop through every cell in column A starting in row 2
For Each Rng In Range("A2:A" & lr)
s = Rng.Value
arr1 = Split(s, "\")
Rng.Offset(0, 1).Value = arr1(UBound(arr1))
arr2 = Split(arr1(UBound(arr1, 1)), "(")
arr3 = Split(arr2(0), "-")
' If first member of array is blank, choose the second
If Left(arr2(0), 1) = "-" Then
Rng.Offset(0, 2).Value = Replace(arr2(0), ".jpg", "")
Else
Rng.Offset(0, 2).Value = Replace(arr3(0), ".jpg", "")
End If
Next Rng
Application.ScreenUpdating = True
End Sub
the result of the code
PATH
FILENAME
CODE
\server-pc\catalog\111138(1).jpg
111138(1).jpg
111138
\server-pc\catalog\111138(2).jpg
111138(2).jpg
111138
\server-pc\catalog\111138(3).jpg
111138(3).jpg
111138
\server-pc\catalog\11-11-38(1).jpg
11-11-38(1).jpg
11
\server-pc\catalog\1-11-8(1).jpg
1-11-8(1).jpg
1
\server-pc\catalog\111170(0).jpg
111170(0).jpg
111170
\server-pc\catalog\111170(1).jpg
111170(1).jpg
111170
\server-pc\catalog\11-11-70-1(2).jpg
11-11-70(2).jpg
11
\server-pc\catalog\1-11-7(1).jpg
1-11-7(1).jpg
1
Desired Result
PATH
FILENAME
CODE
\server-pc\catalog\111138(1).jpg
111138(1).jpg
111138
\server-pc\catalog\111138(2).jpg
111138(2).jpg
111138
\server-pc\catalog\111138(3).jpg
111138(3).jpg
111138
\server-pc\catalog\11-11-38(1).jpg
11-11-38(1).jpg
11-11-38
\server-pc\catalog\1-11-8(1).jpg
1-11-8(1).jpg
1-11-8
\server-pc\catalog\111170(0).jpg
111170(0).jpg
111170
\server-pc\catalog\111170(1).jpg
111170(1).jpg
111170
\server-pc\catalog\11-11-70(2).jpg
11-11-70(2).jpg
11-11-70
\server-pc\catalog\1-11-7(1).jpg
1-11-7(1).jpg
1-11-7
Sub GetFileNametest()
Dim Rng As Range
Dim arr1() As String
Dim arr2() As String
Dim arr3() As String
Dim s As String
Application.ScreenUpdating = False
' Find last row in column A with data
Sheets("Master").Select
lr = Cells(Rows.Count, "A").End(xlUp).Row
' Pre-format column C for text
Columns("C:C").NumberFormat = "#"
' Loop through every cell in column A starting in row 2
For Each Rng In Range("A2:A" & lr)
s = Rng.Value
arr1 = Split(s, "\")
Rng.Offset(0, 1).Value = arr1(UBound(arr1))
arr2 = Split(arr1(UBound(arr1, 1)), "(")
'below is the code I changed
arr3 = Split(arr2(0), "(")
' If first member of array is blank, choose the second
'below is the code I changed
If Left(arr2(0), 1) = "(" Then
Rng.Offset(0, 2).Value = Replace(arr2(0), ".jpg", "")
Else
Rng.Offset(0, 2).Value = Replace(arr3(0), ".jpg", "")
End If
Next Rng
Application.ScreenUpdating = True
End Sub
Related
I am looking for if it is possible to get the data and headers from a table as in the example image and have the output go to two columns with the first column being a repeating header? I did try the transpose however the email row kept populating up to column E.
Please, try the next way. It uses arrays being fast even for large ranges, mostly working in memory. It returns starting from "F2". It is able to process any other columns you (may) need, after "Status":
Sub TransposeMails()
Dim sh As Worksheet, lastR As Long, lastCol As Long
Dim arrH, arr, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet 'use here the necessary sheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column 'last column
arrH = Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2) 'place headers in an array
arr = sh.Range("A2", sh.cells(lastR, lastCol)).Value2 'place the range to be processed (except headers) in an array for faster iteration/processing
ReDim arrFin(1 To (UBound(arrH) + 1) * UBound(arr), 1 To 2) 'Redim the final array (keeping the processed result)
'+ 1 for the empty rows in between...
For i = 1 To UBound(arr)
For j = 1 To UBound(arrH)
k = k + 1
arrFin(k, 1) = arrH(j, 1): arrFin(k, 2) = arr(i, j)
Next j
k = k + 1 'for the empty row between groups...
Next i
'drop the processed array content:
sh.Range("G2").Resize(UBound(arrFin), 2).Value2 = arrFin
End Sub
The code can be easily adapted to return anywhere (another sheet, workbook, range etc).
The range to be processed must start from "A1" ("Email" header) and not having any other record after the last header (on the first row)...
Transpose Data
Sub TransposeData()
Const SRC_NAME As String = "Sheet1"
Const DST_NAME As String = "Sheet1"
Const DST_FIRST_CELL As String = "A8"
Const EMPTY_COLS As Long = 0
Const EMPTY_ROWS As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim drOffset As Long: drOffset = srg.Columns.Count + EMPTY_ROWS
Dim dcOffset As Long: dcOffset = 1 + EMPTY_COLS
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
Application.ScreenUpdating = False
Dim srrg As Range, shrg As Range
Dim IsHeaderReady As Boolean, IsFirstRowDone As Boolean
For Each srrg In srg.Rows
If Not IsHeaderReady Then
srrg.Copy
dfCell.PasteSpecial Transpose:=True
Set shrg = dfCell.Resize(srg.Columns.Count) ' transpose no more
IsHeaderReady = True
Else ' header is ready; it's already copied for the first data row
If IsFirstRowDone Then shrg.Copy dfCell Else IsFirstRowDone = True
srrg.Copy
dfCell.Offset(, dcOffset).PasteSpecial Transpose:=True
Set dfCell = dfCell.Offset(drOffset)
End If
Next srrg
Application.ScreenUpdating = True
MsgBox "Data transposed.", vbInformation
End Sub
If I understand you correctly
Sub test()
'set the range of the header as rg variable
'count how many data under EMAIL header as cnt variable
Dim rg As Range: Set rg = Range("A1", Range("A1").End(xlToRight))
Dim cnt As Integer: cnt = Range(rg, rg.End(xlDown)).Rows.Count - 1
Dim i As Integer: Dim rslt As Range
'loop to each range with data as many as the cnt value
'prepare the result range as rslt variable
'put the value of header name to rslt range
'put the looped range value to rslt.offset(0,1)
For i = 1 To cnt
Set rslt = Range("A" & Rows.Count).End(xlUp).Offset(3, 0) _
.Resize(rg.Columns.Count, 1)
rslt.Value = Application.Transpose(rg)
rslt.Offset(0, 1).Value = Application.Transpose(rg.Offset(i, 0))
Next
End Sub
Please note, the code must be run where the sheet contains the data is active.
I've got two worksheets. The first (Calculation) contains 10.000 rows with a lot of RTD formulas and different calculations. The second (observer) observes the first one.
I've got a VBA script that runs every second and checks every row of worksheet 1 (Calculation). If the loop finds some marked data on worksheet 1 then it will copy some data from WS1 to WS2.
Solution 1: Loop checking 10.000 rows
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For I = 1 To 10000
If CStr(.Cells(I, 1)) = "X" Then
'DO SOME SUFF (copy the line from WS 1 to WS2)
'Find first empty row
LR2 = WS2.Cells(15, 1).End(xlDown).Row + 1
'Copy data from WS1 to WS2
WS1.Range(.Cells(I, 1), .Cells(I, 14)).Copy
WS2.Cells(LR2, 1).PasteSpecial xlValues
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Solution 2: Array function with a small loop
Can I use, instead of the 10.000 row loop, an Excel Array to observe the 10.000 rows and do some stuff with the smaller array.
On worksheet 2, I would have this code: (A1:O15)
{=index(Calculation!A$1:$O$10000; .....)....))}
Again I would have a smaller loop through the 15 lines of array function:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For K = 1 To 15
If CStr(.Cells(I, 1)) = "X" Then
'Find first empty row
LR2 = WS2.Cells(15, 1).End(xlDown).Row + 1
'Copy data from WS1 to WS2
WS1.Range(.Cells(I, 1), .Cells(I, 14)).Copy
WS2.Cells(LR2, 1).PasteSpecial xlValues
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
I would like to know what solution has the better performance.
I am not sure if an Excel array over 10.000 rows has a good performance. For sure the 15-rowLoop is faster than a 10000-row-Loop.
I don't know how to measure if a 15-row Loop in connection with an array (observing 10.000 rows) is faster.
Copy to Sheet With Criteria
Copies each row of a dataset in a worksheet containing a specified value (Criteria) in a specified column, to another worksheet.
Adjust the values in the constants section of createReport.
The data transfer will only (always) happen when the worksheet "Observer" is activated e.g. when another sheet is currently selected and the "Observer" tab is clicked on.
This code took about 5 seconds for a million (all) rows, and under a second for 100.000 rows on my machine.
The efficiency can further be improved by using the code with the Worksheet Change event in the "Calculation" worksheet and by turning off certain Application events (e.g. .ScreenUpdating, .Calculation, .EnableEvents).
Excel Test Setup (Worksheet "Calculation")
[A1:I1] ="Column "&COLUMN()
[A2] =IF(I2=1,"X","Y")
[B2:H2] =RANDBETWEEN(1,1000)
[I2] =RANDBETWEEN(1,100)
Sheet Module (Worksheet "Observer")
Option Explicit
Private Sub Worksheet_Activate()
createReport
End Sub
Standard Module e.g. Module1
Option Explicit
Sub createReport()
' Constants
' Source
Const srcName As String = "Calculation"
Const CriteriaColumn As Long = 1
Const Criteria As String = "X"
Const srcFirstCellAddress As String = "A1"
' Target
Const tgtName As String = "Observer"
Const tgtFirstCellAddress As String = "A1"
Const includeHeaders As Boolean = True
' Other
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Range ('rng').
' Define Source First Cell ('cel').
Dim cel As Range
Set cel = wb.Worksheets(srcName).Range(srcFirstCellAddress)
' Define the Current Region ('rng') 'around' First Cell.
Dim rng As Range
Set rng = cel.CurrentRegion
' Define Source Range ('rng') i.e. exclude cells to the left and above
' of Source First Cell from the Current Region.
Set rng = rng.Resize(rng.Rows.Count - cel.Row + rng.Row, _
rng.Columns.Count - cel.Column + rng.Column) _
.Offset(cel.Row - rng.Row, cel.Column - rng.Column)
' Write values from Source Range to Data Array ('Data').
Dim Data As Variant
Data = rng.Value
' Write resulting values from Data Array to Data Array
' i.e. 'shift' them to the beginning.
Dim NoC As Long ' Number of Columns
NoC = UBound(Data, 2)
Dim i As Long ' Source Data Rows Counter
Dim j As Long ' Source/Target Data Columns Counter
Dim CurrentRow As Long ' Target Data Rows Counter
Dim checkHeaders As Long
checkHeaders = -CLng(includeHeaders) ' True is '-1' in VBA.
CurrentRow = checkHeaders
For i = 1 To UBound(Data, 1)
If Data(i, CriteriaColumn) = Criteria Then
CurrentRow = CurrentRow + 1
For j = 1 To NoC
' 'Shift' from 'i' to 'CurrentRow'.
Data(CurrentRow, j) = Data(i, j)
Next j
End If
Next i
' Write values from Data Array to Target Range ('rng').
' Define Target First Cell ('cel').
Set cel = wb.Worksheets(tgtName).Range(tgtFirstCellAddress)
' Define Target First Row ('rng').
Set rng = cel.Resize(, NoC)
' Clear contents in columns.
rng.Resize(rng.Worksheet.Rows.Count - cel.Row + 1).ClearContents
Select Case CurrentRow
Case 0
GoTo CriteriaNotFound
Case checkHeaders
' Write headers from Data Array to Target Range.
rng.Resize(CurrentRow).Value = Data
GoTo CriteriaNotFound
Case Else
' Write values from Data Array to Target Range.
rng.Resize(CurrentRow).Value = Data
GoTo Success
End Select
' Exit.
ProcExit:
Exit Sub
' Inform user.
CriteriaNotFound:
MsgBox "Value '" & Criteria & "' not found.", vbExclamation, "Fail"
GoTo ProcExit
Success:
MsgBox CurrentRow - checkHeaders & " row(s) of data transferred.", _
vbInformation, "Success"
GoTo ProcExit
End Sub
Rather than going back to column A 10,000 times, bring all the values into a 1D VBA array and then loop over that array:
Sub whatever()
Dim rng As Range, arr
Set rng = Sheets("Calculation").Range("A1:A10000")
arr = WorksheetFunction.Transpose(rng)
For i = 1 To 10000
If arr(i) = "X" Then
'do some stuff
End If
Next i
End Sub
If there are very few X's then it may be nearly instantaneous.
EDIT#1:
Based on Chris Neilsen's comment, here is a version that does not use Transpose():
Sub whatever2()
Dim rng As Range, arr
Set rng = Sheets("Calculation").Range("A1:A10000")
arr = rng
For i = 1 To 10000
If arr(i, 1) = "X" Then
'do some stuff
End If
Next i
End Sub
Test the next code, please. It should be very fast, using arrays and everything happening in memory. The code assumes that you need to copy all occurrences starting with the last empty cell of WS2:
Sub CopyFromWS1ToWs2Array()
Dim WS1 As Worksheet, WS2 As Worksheet, lastRow As Long, searchStr As String
Dim LR2 As Long, arr1 As Variant, arr2 As Variant, i As Long, k As Long, j As Long
Set WS1 = ActiveSheet 'use here your necessary sheet
Set WS2 = WS1.Next 'use here your necessary sheet. I used this only for testing reason
lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
arr1 = WS1.Range("A1:N" & lastRow).Value 'put the range in an array
ReDim arr2(1 To UBound(arr1, 2), 1 To UBound(arr1)) 'redim the array to be returned
'columns and rows are reversed because
'only the second dimension can be Redim Preserve(d)
searchStr = "X" 'setting the search string
For i = 1 To UBound(arr1)
If arr1(i, 1) = searchStr Then
k = k + 1 'the array row is incremented (in fact, it is the column now...)
For j = 1 To UBound(arr1, 2)
arr2(j, k) = arr1(i, j) 'the row is loaded with all the necessary values
Next j
End If
Next i
'the final array is Redim, preserving only the existing values:
ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To k)
LR2 = WS2.cells(rows.count, 1).End(xlUp).row + 1 'last empty row of the second worksheet
'Dropping the array content at once (the fastest way of copying):
WS2.Range("A" & LR2).Resize(UBound(arr2, 2), UBound(arr2)).Value = _
WorksheetFunction.Transpose(arr2)
WS2.Activate: WS2.Range("A" & LR2).Select
MsgBox "Ready...", vbInformation, "Job done"
End Sub
Edited:
Please, test the next code, which should also solve your last requests (as I understood them):
Sub CopyFromWS1ToWs2ArrayBis()
Dim WS1 As Worksheet, WS2 As Worksheet, lastRow As Long, searchStr As String
Dim LR2 As Long, arr1 As Variant, arr2 As Variant, arrWS2 As Variant
Dim i As Long, k As Long, j As Long, s As Long, boolFound As Boolean
Set WS1 = ActiveSheet 'use here your necessary sheet
Set WS2 = WS1.Next 'use here your necessary sheet. I used this only for testing reason
lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
LR2 = WS2.cells(rows.count, 1).End(xlUp).row 'last empty row of the second worksheet
arr1 = WS1.Range("A1:N" & lastRow).Value 'put the range of WS1 in an array
ReDim arr2(1 To UBound(arr1, 2), 1 To UBound(arr1)) 'redim the array to be returned
'columns and rows are reversed because
'only the second dimension can be Redim Preserve(d)
arrWS2 = WS2.Range("A1:N" & LR2).Value 'put the range of WS2 in an array
searchStr = "X" 'setting the search string
For i = 1 To UBound(arr1)
If arr1(i, 1) = searchStr Then
For s = 1 To UBound(arrWS2)
If arr1(i, 1) = arrWS2(s, 1) And arr1(i, 2) = arrWS2(s, 2) And _
arr1(i, 3) = arrWS2(s, 3) Then
boolFound = True: Exit For 'if first three array columns are the same
End If
Next s
If Not boolFound Then 'if first thrree array columns not the same:
k = k + 1 'the array row is incremented
For j = 1 To UBound(arr1, 2)
arr2(j, k) = arr1(i, j) 'the row is loaded with all the necessary values
Next j
'swap the columns 4 and 5 values:
If arr1(i, 4) = "ABC" And arr1(i, 5) = "XYZ" Then arr2(4, k) = "XYZ": arr2(5, k) = "ABC"
End If
boolFound = False 'reinitialize the boolean variable
End If
Next i
If k > 0 Then
'Preserving only the existing array elements:
ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To k)
'Dropping the array content at once (the fastest way of copying):
WS2.Range("A" & LR2 + 1).Resize(UBound(arr2, 2), UBound(arr2)).Value = _
WorksheetFunction.Transpose(arr2)
WS2.Activate: WS2.Range("A" & LR2 + 1).Select
MsgBox "Ready...", vbInformation, "Job done"
Else
MsgBox "No any row to be copied!", vbInformation, "Nothing changed"
End If
End Sub
Anybody please help me figure my problem out?
Dim attPresent as Variant ' attpresent()
Set ws = thisworkbook.sheets("Sheet1")
lastrow = ws.cells(Rows.count, 8).end(xlup).row
attPresent = ws.Range("H4:H" & lastrow).Value 'errors if I use Dim attPresent() As Variant
For k = LBound(attPresent, 1) To UBound(attPresent, 1) ' Dim attPresent As Variant'errors if I use
msgbox attpresent(k,1)
Next
This line attPresent = ws.Range("H4:H" & lastrow).Value returns an error if I declare the variable as Dim attPresent() As Variant. Whereas, if declare the variable as Dim attPresent As Variant, this line For k = LBound(attPresent, 1) To UBound(attPresent, 1) errors.
Can anyone please help me clear this out?Thanks
As a good practice, try to remember to use Option Explicit, and also declare all your variables.
When you use Dim attPresent() As Variant to declare you array , and later on you insert values from a Range to your Array with attPresent = .Range("H4:H" & lastrow).Value, it will automatically Redim your array to 2-dimensinal array (1 to Row number, 1 to Column Number).
Option Explicit
Sub RngtoArray()
Dim attPresent() As Variant
Dim ws As Worksheet
Dim lastrow As Long
Dim k As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lastrow = .Cells(.Rows.Count, 8).End(xlUp).Row
attPresent = .Range("H4:H" & lastrow).Value
End With
For k = 1 To UBound(attPresent, 1)
MsgBox attPresent(k, 1)
Next
End Sub
Edit 1: A slightly different approach, in case there is only 1 cell in the Range:
With ws
lastrow = .Cells(.Rows.Count, 8).End(xlUp).Row
' for single column only - create a 1-Dimension array
ReDim attPresent(1 To lastrow - 4 + 1) ' when the Range starts from "H4"
For k = 1 To UBound(attPresent)
attPresent(k) = .Cells(4 + k - 1, "H")
Next k
End With
For k = 1 To UBound(attPresent)
MsgBox attPresent(k)
Next
I tried to separate the stuff that you had already defined but for clarity I thought I'd provide my full code:
Sub test()
Dim lastrow, i As Integer
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1")
Dim attPresent() As Variant
lastrow = ws.Cells(Rows.Count, "H").End(xlUp).Row
ReDim attPresent(lastrow - 4)
For i = 4 To lastrow
attPresent(i - 4) = ws.Range("H" & i).Value
Next
msg = Join(attPresent, " ")
MsgBox "The array holds: " & vbNewLine & msg
End Sub
I defined the array without a size to begin with then redefined it to the size it needs to be at a later stage once you know the lastrow (as you started on 4 i deducted 4 from lastrow).
I guessed the msgBox was to test what you had gathered so I created a dump that prints them all into one box but obviously change that if you have a lot of data. xD
To work with arrays I always loop through each individual entry, storing them one at a time. I'm not even sure whether you can dump an entire range into one in one step as I've never even looked into it. Anyway, I hope this solves your problem kupo.
Function RangeToArray(rng As Range)
Dim myArray() As Variant, ws As Worksheet
fr = rng.Row
fc = rng.Column
r = rng.Rows.Count
c = rng.Columns.Count
Set ws = rng.Worksheet
ReDim myArray(r - 1, c - 1)
For i = 0 To r - 1
For j = 0 To c - 1
myArray(i, j) = ws.Cells(fr + i, fc + j).Value2
Next j
Next i
RangeToArray = myArray
End Function
Sub f()
Dim rng As Range, attPresent() As Variant ' attpresent()
Set ws = ThisWorkbook.ActiveSheet 'Sheets("Sheet1")
lastrow = ws.Cells(Rows.Count, 8).End(xlUp).Row
Set rng = ws.Range("H4:H" & lastrow)
attPresent = RangeToArray(rng)
For k = LBound(attPresent, 1) To UBound(attPresent, 1) ' Dim attPresent As Variant'errors if I use
MsgBox attPresent(k, 0)
Next
End Sub
I created a more generic function that you can call in this specific case as well.
I got help with this code but when it runs it does not execute what it needs to do. I'm trying to extract words that are underlined and italicized from row C of the first sheet and move them to the secondsheet. The expected outcome is in the second image. Would array splitting be of use in this situation? Hopefully the sample data make it more clear.
Sub proj()
For Each cl In Range("C1:C5")
Call CopyItalicUnderlined(cl, Worksheets("Sheet2").Range("A1"))
Next
End Sub
Sub CopyItalicUnderlined(rngToCopy, rngToPaste)
rngToCopy.Copy rngToPaste
Dim i
For i = Len(rngToCopy.Value2) To 1 Step -1
With rngToPaste.Characters(i, 1)
If Not .Font.Italic And Not .Font.Underline Then
.Text = vbNullString
End If
End With
Next
End Sub
Split() could help, but only after you already found out and parsed italic words since Characters() method can be called on Range object only
you could then try the following code:
Option Explicit
Sub proj()
Dim dataRng As range, cl As range
Dim arr As Variant
Set dataRng = Worksheets("ItalicSourceSheet").range("C1:C5") '<--| change "ItalicSourceSheet" with your actual source sheet name
With Worksheets("ItalicOutputSheet") '<--|change "ItalicOutputSheet" with your actual output sheet name
For Each cl In dataRng
arr = GetItalics(cl) '<--| get array with italic words
If IsArray(arr) Then .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr) + 1) = Application.Transpose(arr) '<--| if array is filled then write it down to output sheet first blank cell in column "A"
Next
End With
End Sub
Function GetItalics(rng As range) As Variant
Dim strng As String
Dim iEnd As Long, iIni As Long, strngLen As Long
strngLen = Len(rng.Value2)
iIni = 1
Do While iEnd <= strngLen
Do While rng.Characters(iEnd, 1).Font.Italic And rng.Characters(iEnd, 1).Font.Underline
If iEnd = strngLen Then Exit Do
iEnd = iEnd + 1
Loop
If iEnd > iIni Then strng = strng & Mid(rng.Value2, iIni, iEnd - iIni) & "|"
iEnd = iEnd + 1
iIni = iEnd
Loop
If strng <> "" Then GetItalics = Split(Left(strng, Len(strng) - 1), "|")
End Function
It's not the prettiest solution, but you can take each cell, put their contents in an array. Then, make some room, and "unload them" and move along.
I tested with some simple data, but if you have errors, can you show more examples of text/data?
Sub proj()
Dim cl As Range
Dim x As Long
x = 0
For Each cl In Sheets("Sheet1").Range("C1:C5")
Call CopyItalicUnderlined(cl, Worksheets("Sheet2").Range("A1").Offset(x, 0))
x = x + 1
Next
Call breakOutWords
End Sub
Sub CopyItalicUnderlined(rngToCopy As Range, rngToPaste As Range)
Dim foundWords() As Variant
rngToCopy.Copy rngToPaste
Dim i
For i = Len(rngToCopy.Value2) To 1 Step -1
With rngToPaste.Characters(i, 1)
Debug.Print .Text
If Not .Font.Italic And Not .Font.Underline Then
If .Text <> " " Then
.Text = vbNullString
Else
.Text = " "
End If
End If
End With
Next
rngToPaste.Value = Trim(rngToPaste.Value)
rngToPaste.Value = WorksheetFunction.Substitute(rngToPaste, " ", " ")
End Sub
Sub breakOutWords()
Dim lastRow As Long, i As Long, k As Long, spaceCounter As Long
Dim myWords As Variant
Dim groupRange As Range
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = lastRow To 1 Step -1
' Determine how many spaces - this means we have X+1 words
spaceCounter = Len(Cells(i, 1)) - Len(WorksheetFunction.Substitute(Cells(i, 1), " ", "")) + 1
If spaceCounter > 1 Then
Set groupRange = Range(Cells(i, 1), Cells(WorksheetFunction.Max(2, i + spaceCounter - 1), 1))
groupRange.Select
myWords = Split(Cells(i, 1), " ")
groupRange.Clear
For k = LBound(myWords) To UBound(myWords)
groupRange.Cells(1 + k, 1).Value = myWords(k)
Next k
Else
' how many new rows will we need for the next cell?
Dim newRows As Long
newRows = Len(Cells(i - 1, 1)) - Len(WorksheetFunction.Substitute(Cells(i - 1, 1), " ", ""))
Range(Cells(i, 1), Cells(i + newRows - 1, 1)).EntireRow.Insert
End If
Next i
End Sub
I think this should work - I modified your code to match your example.
Change the top constants to mark where you want to start appending
into Sheet 2
Change names of Worksheets to match your real life sheets
Change range of cells to check in Set rge = ws1.Range("C8:C100")
Example Code:
Option Explicit
Public Sub ExtractUnderlinedItalicizedWords()
' Where to start appending new words '
Const INSERT_COL As Integer = 1
Const START_AT_ROW As Integer = 1
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rge As Range
Dim cel As Range
Dim c As Object
Dim countChars As Integer
Dim i As Integer
Dim intRow As Integer
Dim strWord As String
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
intRow = START_AT_ROW
' Define the range of cells to check
Set rge = ws1.Range("C8:C100")
For Each cel In rge.Cells
countChars = cel.Characters.count
' Only do this until we find a blank cell
If countChars = 0 Then Exit For
strWord = ""
For i = 1 To countChars
Set c = cel.Characters(i, 1)
With c.Font
If (.Underline <> xlUnderlineStyleNone) And (.Italic) Then
strWord = strWord & c.Text
Else
If Len(strWord) > 0 Then
ws2.Cells(intRow, INSERT_COL).Value = strWord
intRow = intRow + 1
strWord = ""
End If
End If
End With
Next i
' Get Last Word in cell
If Len(strWord) > 0 Then
ws2.Cells(intRow, INSERT_COL).Value = strWord
intRow = intRow + 1
strWord = ""
End If
Next ' Next cell in column range
End Sub
I have the below code from Chandoo for excel. In the 'Data Sheet' it selects the sheet to copy to according to col. C, then copies col. A - G to that spreadsheet and moves to the next entry.
I am having trouble adjusting this code to suit my spreadsheet and would appreciate some assistance. My sheet name is in col. A (not c), and I only require col. B & C to be copied to the sheet. Additionally col. B & C need to be copied into col. B & G in the spreadsheet.
Sub copyPasteData()
Dim strSourceSheet As String
Dim strDestinationSheet As String
Dim lastRow As Long
strSourceSheet = "Data entry"
Sheets(strSourceSheet).Visible = True
Sheets(strSourceSheet).Select
Range("C2").Select
Do While ActiveCell.Value <> ""
strDestinationSheet = ActiveCell.Value
ActiveCell.Offset(0, -2).Resize(1, ActiveCell.CurrentRegion.Columns.Count).Select
Selection.Copy
Sheets(strDestinationSheet).Visible = True
Sheets(strDestinationSheet).Select
lastRow = LastRowInOneColumn("A")
Cells(lastRow + 1, 1).Select
Selection.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Sheets(strSourceSheet).Select
ActiveCell.Offset(0, 2).Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Public Function LastRowInOneColumn(col)
'Find the last used row in a Column: column A in this example
'http://www.rondebruin.nl/last.htm
Dim lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, col).End(xlUp).Row
End With
LastRowInOneColumn = lastRow
End Function
Any assistance in resolving this would be greatly appreciated.
Thank you
This is a leason on the dangers of copying random code form the internet. Manipulating the active selection like this is slow, hard to read, and hard to maintain.
Here's the code refactored to do this task in a more controlled fasion.
The origonal code (refactored) is included, commented out. The code modified to reference your requested cells follows each original line
Sub copyPasteData()
Dim strSourceSheet As String
Dim strDestinationSheet As String
Dim lastRow As Long
Dim wsSource As Worksheet, wsDest As Worksheet
Dim rWs As Range
Dim rSrc As Range, rDst As Range, cl As Range
strSourceSheet = "Data entry"
' Get a reference to the source sheet
Set wsSource = Worksheets(strSourceSheet)
With wsSource
' Get a reference to the list of sheet names
'Set rWs = Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp)) ' for Column C
Set rWs = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)) ' for Column A
' Loop through the sheet names list
For Each cl In rWs.Cells
' Get a reference to the current row of data, all cells on that row
'Set rSrc = cl.EntireRow.Resize(1, .Cells(cl.Row, .Columns.Count).End(xlToLeft).Column)
Set rSrc = cl.EntireRow.Cells(1, 2).Resize(1, 2) ' Reference columns B and C only
' Get a reference to the current Destination sheet
Set wsDest = Worksheets(cl.Value)
With wsDest
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row ' Check last row in Column B
' Copy data to destination using Value array
'.Cells(lastRow + 1, 1).Resize(1, rSrc.Columns.Count).Value = rSrc.Value ' all data
.Cells(lastRow + 1, 2).Value = rSrc.Cells(1, 1) ' copy first cell to column B
.Cells(lastRow + 1, 7).Value = rSrc.Cells(1, 2) ' copy second cell to column G
End With
Next
End With
End Sub