I found this code, which add's one extra column to the chart each time it runs.
Meaning first time it runs it shows week 1-7, secound time 1-8, next 1-9 and I would like it to show 2-7, 3-8, 4-9 ect.
Sub ChartRangeAdd()
On Error Resume Next
Dim oCht As Chart, aFormulaOld As Variant, aFormulaNew As Variant
Dim i As Long, s As Long
Dim oRng As Range, sTmp As String, sBase As String
Set oCht = ActiveSheet.ChartObjects(1).Chart
oCht.Select
For s = 1 To oCht.SeriesCollection.count
sTmp = oCht.SeriesCollection(s).Formula
sBase = Split(sTmp, "(")(0) & "(<FORMULA>)" ' "=SERIES(" & "<FORMULA>)"
sTmp = Split(sTmp, "(")(1) ' "..., ..., ...)"
aFormulaOld = Split(Left(sTmp, Len(sTmp) - 1), ",") ' "..., ..., ..."
aFormulaNew = Array()
ReDim aFormulaNew(UBound(aFormulaOld))
' Process all series in the formula
For i = 0 To UBound(aFormulaOld)
Set oRng = Range(aFormulaOld(i))
' Attempt to put the value into Range, keep the same if it's not valid Range
If Err.Number = 0 Then
Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(0, 1))
aFormulaNew(i) = oRng.Worksheet.Name & "!" & oRng.Address
Else
aFormulaNew(i) = aFormulaOld(i)
Err.Clear
End If
Next i
sTmp = Replace(sBase, "<FORMULA>", Join(aFormulaNew, ","))
Debug.Print "Series(" & s & ") from """ & oCht.SeriesCollection(s).Formula & """ to """ & sTmp & """"
oCht.SeriesCollection(s).Formula = sTmp
sTmp = ""
Next s
Set oCht = Nothing
End Sub
I want to do the opposite of this code, so instead of adding a column one column should be substracted. How can the code be modifued to do this?
(LINK: VBA: Modify chart data range)
Thank you!
Try changing the line
Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(0, 1))
to
Set oRng = oRng.Worksheet.Range(oRng.Offset(0, 1), oRng.Offset(0, 1))
Related
Any help here would be appreciated please.
The included VBA code almost meets the intended purpose, however, I need a solution that enables the use of wildcards and highlights all parameters contained between "##", "%%" or potentially other special characters (special characters included).
For instance, lets say in the cell range B2:B10 we would find something like:
Checked at ##date1## and ##hour1##
But I want to be able to do a search and highlight using # * # or % * % within a selected determined cell range with the end result (bold being color):
Checked at ##date1## and ##hour1##
Sub HighlightStrings()
Application.ScreenUpdating = False
Dim Rng As Range
Dim cFnd As String
Dim xTmp As String
Dim x As Long
Dim m As Long
Dim y As Long
Dim xFNum As Integer
Dim xArrFnd As Variant
Dim xStr As String
cFnd = InputBox("Please enter the text, separate them by comma:")
If Len(cFnd) < 1 Then Exit Sub
xArrFnd = Split(cFnd, ",")
For Each Rng In Selection
With Rng
For xFNum = 0 To UBound(xArrFnd)
xStr = xArrFnd(xFNum)
y = Len(xStr)
m = UBound(Split(Rng.Value, xStr))
If m > 0 Then
xTmp = ""
For x = 0 To m - 1
xTmp = xTmp & Split(Rng.Value, xStr)(x)
.Characters(Start:=Len(xTmp) + 1, Length:=y).Font.ColorIndex = 3
xTmp = xTmp & xStr
Next
End If
Next xFNum
End With
Next Rng
Application.ScreenUpdating = True
End Sub
Thank you
Okay This seems to work for me. There is a limitation we can work on if required: the phrase to highlight must be padded with spaces on both sides.
Option Explicit
Option Base 0
Sub testreplace()
Dim I As Integer 'Iteration
Dim FlagNum As Integer 'Flag Number
Dim RG As Range 'Whole range
Dim CL As Range 'Each Cell
Dim FlagChar As String 'Flag characters
Dim ArrFlag 'Flag Char Array
Dim TextTemp As String 'Cell Contents
Set RG = Selection
FlagChar = "##"
FlagChar = InputBox("Enter 'Flag Characters' separated by a comma." & vbCrLf & vbCrLf & _
"Example:" & vbCrLf & vbCrLf & _
"##,%%,&&" & vbCrLf & _
"$$,XX", "Flag Characters to Highlight", "##,%%")
ArrFlag = Split(FlagChar, ",")
For Each CL In RG.Cells
TextTemp = CL.Value
For FlagNum = 0 To UBound(ArrFlag)
For I = 1 To Len(TextTemp)
'Debug.Print "<<" & Mid(TextTemp, I, Len(ArrFlag(Flagnum)) + 1) & _
"=" & " " & ArrFlag(Flagnum) & ">>"
If Mid(TextTemp, I, Len(ArrFlag(FlagNum)) + 1) = " " & ArrFlag(FlagNum) Then
CL.Characters(I + 1, InStr(I, TextTemp, ArrFlag(FlagNum) & " ") + _
Len(ArrFlag(FlagNum)) - I).Font.ColorIndex = 3
End If
Next I
Next FlagNum
Next CL
End Sub
Here's an example of it working:
I get a mismatch error in this line :
row_str = Join(cell_rng, Chr(10))
Thank you. I am intermediate.
I attached a piece of the code below:
Dim last_row As String
Dim last_col As String
Dim office_str As String
Dim lookupVal As String
Dim i As Long
Dim seperate_cells, cell_rng As Range
Dim r As Range
Dim row_str As String
With Contacts
For i = 2 To last_row
Set cell_rng = Rows(i & ":" & i + 1)
For Each r In cell_rng.Rows
seperate_cells = cellsSeparator(r.SpecialCells(xlCellTypeConstants))
If row_str = "" Then
row_str = Join(cell_rng, Chr(10))
Else
row_str = row_str & vbLf & Join(cell_rng, Chr(10))
End If
Next
Debug.Print row_str
Client_Finder.result.Text = Client_Finder.result.Text & vbLf & row_str
Next i
End With
````
Please try the next way. It will place the values of the necessary specific row in the text box, each value separated by " | ":
Sub testSeparatorsBetweenRowCells()
'your existing code...
Dim arr, rngR As Range
For i = 2 To last_row
lookupVal = cells(i, office_str)
' Compare ComboBox with the range from the spreadsheet
If lookupVal = Office_Code Then
Set rngR = rows(i & ":" & i).SpecialCells(xlCellTypeConstants) 'Set a range which will return all cells value in the row, except the empty ones
arr = arrCells(rngR) 'call a function able to make an array from the range set in the above line
Client_Finder.result.Text = Client_Finder.result.Text & vbLf & Join(arr, " | ") 'add the text obtained by joining the array to the next line of existing text
End If
Next i
End Sub
Function arrCells(rng As Range) As Variant
Dim arr, Ar As Range, i As Long, C As Range
ReDim arr(rng.cells.count - 1) 'ReDim the array to be filled as the range cells number.
'- 1, because the array is 0 based...
For Each Ar In rng.Areas 'iterate between the range areas
For Each C In Ar.cells 'iterate between cells of each area
arr(i) = C.value: i = i + 1 'put each cell value in the array
Next
Next
arrCells = arr 'make the function returning the arr
End Function
If the text in the text box still goes on the next line, try making the text box property WordWrap False. If you cannot see all the text, make the textbox wider or decrease its font size.
Please, test it and send some feedback.
Edited:
Please, try understanding the next piece of code, able to deal with copying more rows at once:
Sub testCopyingMoreRows()
Dim sh As Worksheet, i As Long, rng As Range, r As Range, arr, strRow As String
Set sh = ActiveSheet
i = 9
Set rng = sh.rows(i & ":" & i + 1)
'you ca select cells, rows (even not consecutive) and use:
'Set rng = Selection.EntireRow 'just uncomment this code line...
'extract rows and paste their contents (exept the empty cells) in Imediate Window
For Each r In rng.rows
arr = arrCells(r.SpecialCells(xlCellTypeConstants))
If strRow = "" Then
strRow = Join(arr, " | ")
Else
strRow = strRow & vbLf & Join(arr, " | ")
End If
Next
Debug.Print strRow
'instead returning in Imediate Window, you can do it in your text box (uncomment the next line):
'Client_Finder.result.Text = Client_Finder.result.Text & vbLf & strRow
End Sub
The code uses the same function arrCells...
New to asking questions on this site, and to VBA so please bear with me... I'm compiling this database that is linking drawing numbers that show the same items but each drawing shows a different aspect of that particular 'area' shown in the drawing (I Hope that makes sense). The function that i would like to have is to be able to search just the A column for a value, and return the all of the unique times that the value shows up in the A column and the corresponding B column value. I thought that even with my paltry VBA skills i could manage this but I dont have much so far. This is what i have:
Dim ISO As String
Dim Rng As Range
ISO = InputBox("ISO Number: ", "Enter ISO Number")
If Trim(ISO) <> "" Then
With Sheets("Sheet1").Range("A:A")
Set Rng = .Find(What:=ISO)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox ("Nothing Found")
End If
End With
End If
Thanks in Advance.
I'd use a for loop to iterate over the cells.
Sub FindMatches()
Dim ISO As String
Dim Rng As Range
Dim lastRow As Long, x As Long
Dim ws As Worksheet
Dim foundCount As Long
Dim endString As String
ISO = InputBox("ISO Number: ", "Enter ISO Number")
If Trim(ISO) <> "" Then
Set ws = Sheets("Sheet1") ' always best to use a variable for an object if possible
lastRow = ws.Cells(100000, 1).End(xlUp).Row ' work out how many rows to loop through
For x = 1 To lastRow ' use a for loop to iterate over each row
If ws.Cells(x, 1) = ISO Then
foundCount = foundCount + 1
endString = endString & ws.Cells(x, 2) & vbNewLine ' add column B to the string
End If
Next x
End If
MsgBox "Found " & foundCount & " matches: " & vbNewLine & endString
End Sub
For faster processing you could use an array rather than read from the cells one at at time:
Sub FindMatchesArray()
Dim ISO As String
Dim Rng As Range
Dim lastRow As Long, x As Long
Dim ws As Worksheet
Dim foundCount As Long
Dim endString As String
Dim arr() As Variant
ISO = InputBox("ISO Number: ", "Enter ISO Number")
If Trim(ISO) <> "" Then
Set ws = Sheets("Sheet1") ' always best to use a variable for an object if possible
lastRow = ws.Cells(100000, 1).End(xlUp).Row ' work out how many rows to loop through
arr = ws.Range("A1:B" & lastRow).Value
For x = 1 To lastRow ' use a for loop to iterate over each row
If arr(x, 1) = ISO Then
foundCount = foundCount + 1
endString = endString & arr(x, 2) & vbNewLine ' add column B to the string
End If
Next x
End If
MsgBox "Found " & foundCount & " matches: " & vbNewLine & endString
End Sub
You could use Find and FindNext.
The first Test will return the values in a message box, the second will place the returned values in cell A1 on Sheet2.
I could've sworn this should work as a Worksheetfunction, but no luck (.FindNext won't work in a UDF).
Sub Test()
Dim MyMessage As String
MyMessage = ReturnCountAndValue("5", ThisWorkbook.Worksheets("Sheet1").Columns(1))
MsgBox MyMessage, vbOKOnly + vbInformation
End Sub
Sub Test2()
With ThisWorkbook
.Worksheets("Sheet2").Range("A1") = ReturnCountAndValue(.Worksheets("Sheet1").Range("K2"), _
.Worksheets("Sheet1").Range("F2:F9"))
End With
End Sub
Public Function ReturnCountAndValue(SearchValue As String, _
SearchColumn As Range) As String
Dim rFound As Range
Dim sFirstAddress As String
Dim sTempReturn As String
Dim lCounter As Long
With SearchColumn
Set rFound = .Find(What:=SearchValue, LookIn:=xlValues, LookAt:=xlWhole)
If Not rFound Is Nothing Then
sFirstAddress = rFound.Address
Do
lCounter = lCounter + 1
sTempReturn = sTempReturn & rFound.Offset(, 1).Value & vbCr
Set rFound = .FindNext(rFound)
Loop While rFound.Address <> sFirstAddress
sTempReturn = lCounter & " items found. " & vbCr & _
sTempReturn
Else
sTempReturn = SearchValue & " not found in range " & SearchColumn.Address
End If
End With
ReturnCountAndValue = sTempReturn
End Function
I have two spreadsheets (wb and wbtemp); both have a column for location and a column for feature type. In VBA, I want to find all of the rows on the second sheet where the two columns are the same as the two columns on a row in the first sheet and get a list or a range made up of the row numbers/indices.
I then want to use this range to pull out values from a different column and find the highest object in it, but I think I will probably be able to do that if I can get this range sorted.
Dim wb As Workbook
Dim ws As Worksheet
Dim Features() As Variant
Dim Activity() As Variant
Dim Benthic As Variant
Dim wbtemp As Workbook
Dim BenSenFeatures() As Variant
Dim BenSenActivity() As Variant
Dim LR As Long
Dim LC As Long
Dim r As Long
Dim c As Long
Dim WhatToFind1 As Variant
Dim WhatToFind2 As Variant
Dim rngFound1 As Range
Dim rngFound2 As Range
Dim rng1 As Variant
Dim rng2 As Variant
Dim rngFound As Range
Dim iLoop As Long
Dim colFound As Range
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Features = ws.Range("B:C").Value
Activity = ws.Rows(1).Value
Benthic = InputBox("Filename goes here...")
Set wbtemp = Workbooks.Open(Benthic, True, True)
With wbtemp
BenSenFeatures = .Sheets(1).Range("A:B").Value
BenSenActivity = .Sheets(1).Rows(1).Value
End With
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
LC = ws.Cells(1, Columns.Count).End(xlToLeft).Column
For r = 3 To LR
If Not IsEmpty(Features(r, 2)) Then
If IsInArray(Features(r, 2), BenSenFeatures, 2) Then
'If WorksheetFunction.Match(Features(r, 2), BenSenFeatures(0, 2), 0) Then <---I tried to use the arrays originally
WhatToFind1 = Features(r, 1)
WhatToFind2 = Features(r, 2)
Set rngFound1 = wbtemp.Sheets(1).Columns(1).Cells(wbtemp.Sheets(1).Columns(1).Cells.Count)
Set rngFound2 = wbtemp.Sheets(1).Columns(2).Cells(wbtemp.Sheets(1).Columns(2).Cells.Count)
For iLoop = 1 To WorksheetFunction.CountIf(wbtemp.Sheets(1).Columns(1), WhatToFind1)
Set rngFound1 = wbtemp.Sheets(1).Columns(1).Cells.Find(WhatToFind1, After:=rngFound1)
rng1(iLoop) = rngFound1.Row
'WorksheetFunction.Index(wbtemp.Sheets(1).Range("A:B").Value,_
WorksheetFunction.Match(WhatToFind1 & WhatToFind2,_
wbtemp.Sheets(1).Columns(1) & wbtemp.Sheets(1).Columns(2),_
0), 1) <---originally tried to use match to search for the multiple criteria but couldn't find a way to create a list of indices
Set rngFound2 = wbtemp.Sheets(1).Columns(2).Cells.Find(WhatToFind2, After:=rngFound2)
rng2(iLoop) = rngFound2.Row
Next iLoop
For Each cell In rng1
If Not Application.CountIf(rng2, cell.Value) = 0 Then
rngFound.Cells(Cells(Rows.Count, 1).End(xlUp) + 1) = cell.Value
End If
Next
I originally tried to use .Match to find the multiple criteria, but I couldn't figure out how to create a range of indices from it. Then I tried using .Find to create two list of indices but I can't figure out how to get that to work. I keep getting
Type Mismatch
errors.
I realise this sounds confusing, so let me know if anything needs clarifying.
Something like this should work for you. I tried to comment the code for clarity.
Sub tgr()
Dim wb As Workbook
Dim ws As Worksheet
Dim rData As Range
Dim wbTemp As Workbook
Dim wsTemp As Worksheet
Dim rTempData As Range
Dim aData() As Variant
Dim aTempData() As Variant
Dim aResults() As Variant
Dim lNumResults As Long
Dim DataIndex As Long, TempIndex As Long, ResultIndex As Long, j As Long
Dim sCritRange1 As String, sCritRange2 As String
Dim sCriteria1 As String, sCriteria2 As String
Set wb = ActiveWorkbook
'Adjust these two as necessary
Set ws = wb.Sheets(1)
Set rData = ws.Range("B3", ws.Cells(ws.Rows.Count, "B").End(xlUp))
'Select wbTemp file
On Error Resume Next
Set wbTemp = Workbooks.Open(Application.GetOpenFilename("Excel Files, *.xls*"))
On Error GoTo 0
If wbTemp Is Nothing Then Exit Sub 'Pressed cancel
'Adjust these two as necessary
Set wsTemp = wbTemp.Sheets(1)
Set rTempData = wsTemp.Range("A1", wsTemp.Cells(wsTemp.Rows.Count, "A").End(xlUp))
sCritRange1 = rTempData.EntireColumn.Address(external:=True)
sCritRange2 = rTempData.Offset(, 1).EntireColumn.Address(external:=True)
sCriteria1 = rData.Address(external:=True)
sCriteria2 = rData.Offset(, 1).Address(external:=True)
lNumResults = Evaluate("SUMPRODUCT(COUNTIFS(" & sCritRange1 & "," & sCriteria1 & "," & sCritRange2 & "," & sCriteria2 & "))")
If lNumResults = 0 Then Exit Sub 'No matches
ReDim aResults(1 To lNumResults, 1 To 3)
aData = rData.Resize(, 2).Value
aTempData = rTempData.Resize(, 2).Value
'Loop through both data ranges
For DataIndex = LBound(aData, 1) To UBound(aData, 1)
For TempIndex = LBound(aTempData, 1) To UBound(aTempData, 1)
'Find where both criteria matches
If aTempData(TempIndex, 1) = aData(DataIndex, 1) And aTempData(TempIndex, 2) = aData(DataIndex, 2) Then
'Match found, add to results and collect the row index
ResultIndex = ResultIndex + 1
aResults(ResultIndex, 1) = aData(DataIndex, 1)
aResults(ResultIndex, 2) = aData(DataIndex, 2)
aResults(ResultIndex, 3) = "Row: " & TempIndex + rTempData.Row - 1 'This is the row index from wsTemp of the found match
End If
Next TempIndex
Next DataIndex
'Row index results gathered
'Do what you want with the results
'In this example it is just providing msgboxes displaying the results
For ResultIndex = LBound(aResults, 1) To UBound(aResults, 1)
MsgBox "Location: " & aResults(ResultIndex, 1) & Chr(10) & _
"Feature: " & aResults(ResultIndex, 2) & Chr(10) & _
"RowIndex: " & aResults(ResultIndex, 3)
Next ResultIndex
'Close wbTemp
wbTemp.Close
End Sub
I made some minor modifications to tigeravatar's answer to get it to work with my data:
Mainly creating a loop which cycled through each row in wb so that the criteria used with CountIfs was a single value and not a range of values.
I swapped the Evaluate("SUMPRODUCT(COUNTIFS(" & sCritRange1 & "," & sCriteria1 & "," & sCritRange2 & "," & sCriteria2 & "))") for Application.WorksheetFunction.CountIfs(Range(sCritRange1), Range(sCriteria1).Value, Range(sCritRange2), Range(sCriteria2).Value)
I would like to thank tigeravatar for their help.
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
LC = ws.Cells(1, Columns.Count).End(xlToLeft).Column
For r = 3 To LR
sCritRange1 = rTempData.EntireColumn.Address(external:=True)
sCritRange2 = rTempData.Offset(, 1).EntireColumn.Address(external:=True)
sCriteria1 = rData(r, 1).Address(external:=True)
sCriteria2 = rData(r, 1).Offset(, 1).Address(external:=True)
lNumResults = Application.WorksheetFunction.CountIfs(Range(sCritRange1), Range(sCriteria1).Value, Range(sCritRange2), Range(sCriteria2).Value)
If lNumResults = 0 Then Exit Sub 'No matches
ReDim aResults(1 To lNumResults, 1 To 3)
aData = rData(r, 1).Resize(, 2).Value
aTempData = rTempData.Resize(, 2).Value
'Loop through both data ranges
For DataIndex = LBound(aData, 1) To UBound(aData, 1)
For TempIndex = LBound(aTempData, 1) To UBound(aTempData, 1)
'Find where both criteria matches
If Not IsEmpty(aTempData(TempIndex, 1)) Then
If aTempData(TempIndex, 1) = aData(DataIndex, 1) And aTempData(TempIndex, 2) = aData(DataIndex, 2) Then
'Match found, add to results and collect the row index
ResultIndex = ResultIndex + 1
aResults(ResultIndex, 1) = aData(DataIndex, 1)
aResults(ResultIndex, 2) = aData(DataIndex, 2)
aResults(ResultIndex, 3) = "Row: " & TempIndex + rTempData.Row - 1 'This is the row index from wsTemp of the found match
End If
End If
Next TempIndex
Next DataIndex
Next r
I am trying to get 2 For loops to increment at the same time but am only able to get it to where one loop increments and after that loop has gone through its complete loop then the 2nd loop increments. I would like for the code to go down the list of both loops at the same time where it goes:
set criteria1 (1) and criteria2 (1) to the rngstart and rngend
then runs the For i = (rngStart.Row + 2) To (rngEnd.Row - 3) section and outputs to a text file
then set criteria1 (2) and criteria2 (2) to the rngstart and rngend
then runs the For i = (rngStart.Row + 2) To (rngEnd.Row - 3) section and outputs to a text file
etc.
Any guidance on what I am doing wrong and how to resolve the issue would be greatly appreciated.
Below is the code I am trying to resolve the issue with:
Sub ExportStuffToText()
Dim rngFind As Range, rngStart As Range, rngEnd As Range, rngPrint As Range, cell As Range
Dim Criteria1, Criteria2
Dim sTextPath
Dim strCriteria1() As String
Dim strCriteria2() As String
Dim a As Integer, b As Integer, i As Integer, j As Integer
Dim intCriteria1Max As Integer
Dim intCriteria2Max As Integer
Dim FileNum As Integer
Dim str_text As String
Dim sLine As String
Dim sType As String
Set rngFind = Columns("B")
intCriteria1Max = 5
ReDim strCriteria1(1 To intCriteria1Max)
strCriteria1(1) = "Entry1"
strCriteria1(2) = "Entry2"
strCriteria1(3) = "Entry3"
strCriteria1(4) = "Entry4"
strCriteria1(5) = "Entry5"
intCriteria2Max = 5
ReDim strCriteria2(1 To intCriteria2Max)
strCriteria2(1) = "Entry2"
strCriteria2(2) = "Entry3"
strCriteria2(3) = "Entry4"
strCriteria2(4) = "Entry5"
strCriteria2(5) = "Entry6"
For a = 1 To intCriteria1Max
For b = 1 To intCriteria2Max
Criteria1 = strCriteria1(a)
Set rngStart = rngFind.Find(What:=Criteria1, LookIn:=xlValues)
sTextPath = rngStart
Criteria2 = strCriteria2(b)
Set rngEnd = rngFind.Find(What:=Criteria2, LookIn:=xlValues)
If rngStart Is Nothing Then
MsgBox "Criteria1 not found"
Exit Sub
ElseIf rngEnd Is Nothing Then
MsgBox "Criteria2 not found"
Exit Sub
End If
FileNum = FreeFile
str_text = ""
For i = (rngStart.Row + 2) To (rngEnd.Row - 3)
sLine = ""
sType = Sheets![Sheetnamegoeshere].Cells(i, 8).Text
If sType = "somestring" Or sType = "adifferentstring" Then
For j = 1 To 2
If j > 1 Then
sLine = sLine & vbTab
End If
sLine = sLine & Sheets![Sheetnamegoeshere].Cells(i, j).Text
Next j
If Not Len(Trim(Replace(sLine, vbTab, ""))) = 0 Then
If i > 4 Then
str_text = str_text & IIf(str_text = "", "", vbNewLine) & sLine
End If
End If
End If
Next
Open sTextPath For Append As #FileNum
Print #FileNum, str_text
Close #FileNum
str_text = ""
Next b
Next a
End Sub
Ok I made some modifications in the code. I should be working but I did not test it. Give it a try.
Note that I split the original procedure into three smaller ones. Usually if you have a huge amount of variables on the top, it's a sign that the procedure is too large.
Option Explicit
Sub ExportStuffToText()
Dim shToWork As Worksheet
Dim arrCriteria(4, 1) As String
Dim strText As String
Dim rngFind As Range
Dim rngStart As Range
Dim rngEnd As Range
' Add the criterias pairs
arrCriteria(0, 0) = "Entry1"
arrCriteria(0, 1) = "Entry2"
arrCriteria(1, 0) = "Entry2"
arrCriteria(1, 1) = "Entry3"
arrCriteria(2, 0) = "Entry3"
arrCriteria(2, 1) = "Entry4"
arrCriteria(3, 0) = "Entry4"
arrCriteria(3, 1) = "Entry5"
arrCriteria(3, 0) = "Entry5"
arrCriteria(3, 1) = "Entry6"
' Put the name of the sheet here "Sheetnamegoeshere"
Set shToWork = Sheets("Sheetnamegoeshere")
Set rngFind = shToWork.Columns("B")
Dim t As Long
' Loop through my criteria pairs.
For t = LBound(arrCriteria, 1) To UBound(arrCriteria, 1)
'Try to find the values pair.
Set rngStart = rngFind.Find(what:=arrCriteria(t, 0), LookIn:=xlValues)
Set rngEnd = rngFind.Find(what:=arrCriteria(t, 1), LookIn:=xlValues)
If Not rngStart Is Nothing And Not rngEnd Is Nothing Then
' Create the text to append.
strText = GetStringToAppend(rngStart, rngEnd)
'Write to the file
WriteToFile rngStart.Value, strText
Else
' If one or more of the ranges is nothing then
' show a message.
If rngStart Is Nothing Then
MsgBox "Criteria1 not found"
Exit Sub
ElseIf rngEnd Is Nothing Then
MsgBox "Criteria2 not found"
Exit Sub
End If
End If
Next t
End Sub
'Creates a string that will be append to the file.
Function GetStringToAppend(ByRef rStart As Range, _
ByRef rEnd As Range) As String
Dim sh As Worksheet
Dim sLine As String
Dim sType As String
Dim ret As String
Dim i As Long, j As Long
'Grab the sheet from one of the ranges.
Set sh = rStart.Parent
For i = (rStart.Row + 2) To (rEnd.Row - 3)
sType = sh.Cells(i, 8).Text
If sType = "somestring" Or sType = "adifferentstring" Then
For j = 1 To 2
If j > 1 Then
sLine = sLine & vbTab
End If
sLine = sLine & sh.Cells(i, j).Text
Next j
If Not Len(Trim$(Replace(sLine, vbTab, vbNullString))) = 0 Then
If i > 4 Then
ret = ret & IIf(ret = vbNullString, vbNullString, vbNewLine) & sLine
End If
End If
End If
Next
'Return the value
GetStringToAppend = ret
End Function
'Procedure to write to the file.
Sub WriteToFile(ByVal strFilePath As String, _
ByVal strContent As String)
Dim FileNum As Integer
FileNum = FreeFile
Open strFilePath For Append As #FileNum
Print #FileNum, strContent
Close #FileNum
End Sub
I hope this helps :)