I have the code below but I know it could be sped up by putting the data into an array which I don't know how. I'd appreciate any help.
Thanks In advance
For Each rngReportCell In rngReport
If rngReportCell = "" Then Exit For
If VBA.UCase(rngReportCell.Offset(0, 1).Value) = "X" Then
wkbSOR.Sheets("Dashboard").range("SSSFlag").Value = True
Else
wkbSOR.Sheets("Dashboard").range("SSSFlag").Value = False
End If
If rngRetrieveCell.Offset(0, 1).Value <> "" Then _
wkbSOR.Sheets(rngRetrieveCell.Value).range(rngRetrieveCell.Offset(0, 1).Value) _
= "'" & rngReportCell.Value
If rngReportCell.Offset(0, 2) <> "" And gRetrieveCell.Offset(0, 2).Value <> "" Then _
wkbSOR.Sheets(rngRetrieveCell.Value).range(rngRetrieveCell.Offset(0, 2).Value) _
= "'" & rngReportCell.Offset(0, 2).Value
TotalRows = range("Base_" & rngRetrieveCell).Rows.count
TotalCols = range("Base_" & rngRetrieveCell).Columns.count
'Copies values using range.value = range.value
range("A7").Offset(range("A7").CurrentRegion.Rows.count, 0).Resize(TotalRows, TotalCols).Value = _
wkbSOR.Sheets(rngRetrieveCell.Value).range("Base_" & rngRetrieveCell).Value
Next rngReportCell 'Store/Hyperion code
Maybe this will help you:
https://stackoverflow.com/questions/17859531/excel-vba-populate-array-with-range-from-specific-sheet
But essentially you will want to just import the range that you want into a 2-D array and iterate through as so (for example):
'Instantiate variant array
Dim arrValues() As Variant
arrValues = Sheet1.Range("A1:D10")
'Iterate through rows
For i = 1 To 10
'Iterate through columns
For j = 1 To 10
'your code here
Next
Next
Related
I am trying to design a macro to search for multiple strings in an excel.
I have the following code which searches for the word "techno" in an excel but, I need to include a variable into the code so that I can search for multiple words such "Techno", "electromagnetic", "waves", etc. at once. I am unable to create a loop for this condition.
Can anyone suggest a solution to this problem? The below code works fine but, only a tweak is required to include multiple strings in the search.
Sub SearchFolders()
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
myArray = Array("techno", "magnetic", "laser", "trent")
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a forlder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets.Add
For myCounter = 0 To UBound(myArray)
MsgBox myCounter & " is the Count No."
xStrSearch = myArray(myCounter)
MsgBox xStrSearch & " is the Value fr String search"
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cell"
.Cells(xRow, 4) = "Text in Cell"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "*.xls*")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
Set xFound = xWk.UsedRange.Find(xStrSearch)
MsgBox xFound & " is the strings found"
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else
xCount = xCount + 1
MsgBox xCount & " is the count of strings"
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
.Cells(xRow, 4) = xFound.Value
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
MsgBox xFound & " next string"
MsgBox xStrAddress & " is the address "
MsgBox xFound.Address & " is the address found"
Loop While xStrAddress <> xFound.Address 'To check how xStrAddress is populated or do we need to declare it as a help from excel pointed out
myCounter = myCounter + 1
Next
xWb.Close (False)
xStrFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
Next myCounter
MsgBox xCount & "cells have been found", ,
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
If the strings you are searching will always be the same, hard code them into an array and Loop through the array elements to search each string, like so:
Dim myArray as Variant
Dim myCounter as Long
myArray = Array("techno", "electromagnetic", ...etc.)
For myCounter = 0 To UBound(myArray)
... 'your code here
xStrSearch = myArray(myCounter)
... 'the rest if your code here
Next myCounter
I have the following data:
The problem I'm trying to solve is that sometimes the Column H (Place) and Column I (Country) switch places (ex: lines 9,10,11). What I would like to do is:
First check if the year is within the last 3 years (I don't need to fix data older than that).
Load a range of values into an array.
Compare if the values in Column H are in the array.
If not, then switch values between columns. I did that by simply copying and pasting.
I'm stuck at this point. Sorry if it's ugly, first time dealing with arrays
The list I load into the array is in one workbook and the data is on another workbook. Does it work or they need to be on the same workbook?
Sub check_data()
Sheets("list").Activate 'this workbook
Dim DirArray As Variant
DirArray = Range("a1:a18").Value 'loads the range into an array
mypath = "//mynetworkpath/" 'sets the path
file = Dir(mypath & "filename.csv") 'indicates name of the file
Workbooks.Open (mypath & file) 'opens the file
Dim lastrow As Long
lastrow = Cells(Rows.Count, 2).End(xlUp).Row 'sorting by year
Range("A2:K" & lastrow).Sort key1:=Range("B2:B" & lastrow), _
order1:=xlDescending, Header:=xlNo
end_year = Format(Now, "yyyy") - 3 ' last 3 years
x = 2 'starts from second row
Do Until Cells(x, 2) = end_year 'cells(row,col)
For y = LBound(DirArray) To UBound(DirArray)
If Sheet1.Cells(x, 8) = DirArray(y) Then
Range("H" & x).Select
Selection.Copy
Range("M" & x).Select
ActiveSheet.Paste
Range("I" & x).Select
Application.CutCopyMode = False
Selection.Copy
Range("H" & x).Select
ActiveSheet.Paste
Range("M" & x).Select
Application.CutCopyMode = False
Selection.Copy
Range("I" & x).Select
ActiveSheet.Paste
Exit For
End If
Next
x = x + 1
Loop
ActiveWorkbook.Save
ActiveWorkbook.Close True
End Sub
Any guidance is helpful!
Thanks
You can leave the list on the worksheet and use match to check the values:
Sub check_data()
Const FPATH As String = "\\mynetworkpath\" 'use Const for fixed values
Dim rngVals As Range, wb As Workbook, lastrow As Long
Dim ws As Worksheet, tmp, file
Set rngVals = ThisWorkbook.Sheets("list").Range("a1:a18") 'your lookup list
file = Dir(FPATH & "filename.csv")
If Len(file) > 0 Then
Set wb = Workbooks.Open(FPATH & file) 'opens the file
Set ws = wb.Worksheets(1)
lastrow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
ws.Range("A2:K" & lastrow).Sort key1:=ws.Range("B2:B" & lastrow), _
order1:=xlDescending, Header:=xlNo
end_year = Year(Now) - 3 ' last 3 years
x = 2 'starts from second row
Do Until Cells(x, 2) = end_year 'cells(row,col)
tmp = ws.Cells(x, 8).Value
'use Match to check the value against the list
m = Application.Match(tmp, rngVals, 0)
If Not IsError(m) Then
'got a match, so swap the values from H and I
ws.Cells(x, 8).Value = ws.Cells(x, 9).Value
ws.Cells(x, 9).Value = tmp
End If
x = x + 1
Loop
wb.Save
wb.Close
End If 'got the file
End Sub
I have a few different arrays that are worksheets. What I want to build out is making this code print a group sheets via an array, where the "packages_to_print" array is equal to all the relevant array of sheets that need to printed. If this is not possible, is there a way to select multiple arrays to print?
This code doesn't give me an error, it just doesn't print anything to pdf.
Here's the relevant code. (The lender_package is the same as another variable because I have not built out the case statement for setting that variable to an array yet). Thank you in advance for your help.
Dim common_disclosures As Variant
Dim nh_disclosure As Variant
Dim provident_disclosures As Variant
Dim packages_to_print As Variant
Dim lender_package As Variant
common_disclosures = Array("Certification", "Responsible Use", "Security Procedures", "Acknowledgment", "FACTA Credit Score", "Anti-Steering")
nh_disclosures = Array("Loan Origination and Comp", "Rate Lock", "ECOA")
provident_disclosures = Array("MBFA")
lender_package = Array(provident_disclosures)
If subject_state <> "MA" Then
packages_to_print = Array(common_disclosures, nh_disclosures, lender_package)
Else
packages_to_print = Array(common_disclosures, lender_package)
End If
For j = 1 To (customerpackages * 2)
Worksheets(packages_to_print).Select _
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\users\" & environ_user & "\desktop\" & borrower_array(j - 1) & " disclosures.pdf" _
, Quality:=xlQualityMinimum, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Next j
Actually you are using array of arrays in WorkSheets(..) expression. Try joining the arrays as packages_to_print and it is running OK.
If subject_state <> "MA" Then
packages_to_print = Split(Join(common_disclosures, ",") & "," & Join(nh_disclosures, ",") & "," & Join(lender_package, ","), ",")
Else
packages_to_print = Split(Join(common_disclosures, ",") & "," & Join(lender_package, ","), ",")
End If
Full Trial Code, may try it on any new workbook with 8-8 sheets
Sub test()
Dim common_disclosures As Variant
Dim nh_disclosures As Variant
Dim lender_package As Variant
Dim packages_to_print As Variant
common_disclosures = Array("Sheet1", "Sheet4", "Sheet3", "Sheet2", "Sheet5")
nh_disclosures = Array("Sheet2", "Sheet5")
lender_package = Array("Sheet6", "Sheet8")
subject_state = "MA"
If subject_state <> "MA" Then
packages_to_print = Split(Join(common_disclosures, ",") & "," & Join(nh_disclosures, ",") & "," & Join(lender_package, ","), ",")
Else
packages_to_print = Split(Join(common_disclosures, ",") & "," & Join(lender_package, ","), ",")
End If
Worksheets(packages_to_print).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\user\Desktop\Book1.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End Sub
※ This question is a continuation of below problem
How to use nested loop for a Matrix cell in excel vba
I would like to pass dynamic Array(arguments), and i was trying below, but it is not working correctly. Could you please help me.
Dim StartrowArr, Startrow1Arr, J As Integer
Dim flRow, dtRow As String
Set filRng = Worksheets("Sheet1").Range("C1:C50")
Set dtlRng = Worksheets("Sheet1").Range("F1:F50")
For Each cell In filRng
If cell.Value <> "" Then
ftRow = ftRow & cell.Row & ","
End If
Next cell
ftRow = Left(ftRow, Len(ftRow) - 1)
Debug.Print ftRowNo
For Each cell In dtlRng
If cell.Value <> "" Then
dtRow = dtRow & cell.Row & ","
End If
Next cell
dtRow = Left(dtRow, Len(dtRow) - 1)
Debug.Print dtRow
StartrowArr = Array(filRowNo) ※ dynamic array args
Startrow1Arr = Array(dtlRowNo)
but after initializing Array(args) like above, it returns error 1004 on [Startrow1, init with 0]. I also tried CInt(ftRow) to typecast to Integer from String. nothings changed. Moreover, log shows that Startrow, Startrow1 got values like below.
Startrow: 2, 4, 7
Startrow1: 2611 ※ should be 2, 6, 11
However, If I initialize the StartrowArr = Array(2,4,7), statically. it works perfect.
How can I pass the arguments correctly to StartrowArr and Startrow1Arr.
To making Dynamic array, use redim preserve .
Sub test()
Dim StartrowArr(), Startrow1Arr(), J As Integer
Dim flRow, dtRow As String
Dim Cell As Range
Dim k As Long, n As Long
Set filRng = Worksheets("Sheet1").Range("C1:C50")
Set dtlRng = Worksheets("Sheet1").Range("F1:F50")
For Each Cell In filRng
If Cell.Value <> "" Then
'ftRow = ftRow & cell.Row & ","
ReDim Preserve StartrowArr(k)
StartrowArr(k) = Cell.Row
k = k + 1
End If
Next Cell
'ftRow = Left(ftRow, Len(ftRow) - 1)
Debug.Print Join(StartrowArr, ",")
For Each Cell In dtlRng
If Cell.Value <> "" Then
'dtRow = dtRow & Cell.Row & ","
ReDim Preserve Startrow1Arr(n)
Startrow1Arr(n) = Cell.Row
n = n + 1
End If
Next Cell
'dtRow = Left(dtRow, Len(dtRow) - 1)
Debug.Print Join(Startrow1Arr, ",")
'StartrowArr = Array(mapRowNo) '※ dynamic array args
'Startrow1Arr = Array(tcRowNo)
End Sub
I have this code that gets all file types.
Dim file as variant
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True)
Then I have to print it in the cells on a sheet.
For i = 1 To UBound(file)
lRow = Cells(Rows.count, 15).End(xlUp).Row
lRow = lRow + 1
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = CStr(file(i))
Next i
but what I want is first check the contents of the array. If the array has this file type, then I have to remove it in the arraylist. After that, a message will pop out that this files are removed.
dim arr() as string
arr = Split("ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|hta|inf|ins|isp|its|js|jse|" _
& "ksh|lnk|mad|maf|mag|mam|maq|mar|mas|mat|mau|mav|maw|mda|mdb|mde|mdt|mdw|mdz|msc|msh|msh1|msh2|" _
& "mshxml|msh1xml|msh2xml|ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|" _
& "hta|msi|msp|mst|ops|pcd|pif|plg|prf|prg|pst|reg|scf|scr|sct|shb|shs|ps1|ps1xml|ps2|ps2xml|psc1|psc2|tmp|url|vb|vbe|vbs|vsmacros|vsw|ws|wsc|wsf|wsh|xnk", "|")
I just don't know where I have to start. I have found a little bit same problem here in this post, but I just can't understand it. Thanks!
You can use a RegExp and a varaint array to do this quickly
This code looks for path... dot extension end string so it is more robust than your current array which may remove files based on the path name rather than file type
Sub B()
Dim fName As Variant
Dim objRegex As Object
Dim lngCnt As Long
Dim rng1 As Range
Set objRegex = CreateObject("vbscript.regexp")
On Error Resume Next
fName = Application.GetOpenFilename("All Files, *.*", , "Select file", , True)
If Err.Number <> 0 Then Exit Sub
On Error GoTo 0
With objRegex
.Pattern = ".*\.(ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|hta|inf|ins|isp|its|js|jse|" _
& "ksh|lnk|mad|maf|mag|mam|maq|mar|mas|mat|mau|mav|maw|mda|mdb|mde|mdt|mdw|mdz|msc|msh|msh1|msh2|" _
& "mshxml|msh1xml|msh2xml|ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|" _
& "hta|msi|msp|mst|ops|pcd|pif|plg|prf|prg|pst|reg|scf|scr|sct|shb|shs|ps1|ps1xml|ps2|ps2xml|psc1|psc2|tmp|url|vb|vbe|vbs|vsmacros|vsw|ws|wsc|wsf|wsh|xnk)$"
`replace matching file types with blank array entries
For lngCnt = 1 To UBound(fName)
fName(lngCnt) = .Replace(fName(lngCnt), vbNullString)
Next
End With
Set rng1 = Cells(Rows.Count, 15).End(xlUp).Offset(1,0)
'dump array to sheet
rng1.Resize(UBound(fName), 1) = Application.Transpose(fName)
` remove blank entries
On Error Resume Next
rng1.SpecialCells(xlCellTypeBlanks).Delete xlUp
On Error GoTo 0
End Sub
One way would be to check that the extension it's not present in the blacklist with InStr:
Const exts = _
".ade.adp.app.asp.bas.bat.cer.chm.cmd.com.cpl.crt.csh.der.exe.fxp.gadget" & _
".hlp.hta.inf.ins.isp.its.js.jse.ksh.lnk.mad.maf.mag.mam.maq.mar.mas.mat" & _
".mau.mav.maw.mda.mdb.mde.mdt.mdw.mdz.msc.msh.msh1.msh2.mshxml.msh1xml" & _
".msh2xml.ade.adp.app.asp.bas.bat.cer.chm.cmd.com.cpl.crt.csh.der.exe.fxp" & _
".gadget.hlp.hta.msi.msp.mst.ops.pcd.pif.plg.prf.prg.pst.reg.scf.scr.sct" & _
".shb.shs.ps1.ps1xml.ps2.ps2xml.psc1.psc2.tmp.url.vb.vbe.vbs.vsmacros.vsw" & _
".ws.wsc.wsf.wsh.xnk."
Dim file As Variant
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True)
Dim i As Long, data(), count As Long, ext As String
ReDim data(1 To UBound(file) + 1, 1 To 1)
' filter the list
For i = LBound(file) To UBound(file)
ext = LCase(Mid(file(i), InStrRev(file(i), ".")))
If InStr(1, exts, ext & ".") = 0 Then ' if not blacklisted
count = count + 1
data(count, 1) = file(i)
End If
Next
' copy the filtered list to the next available row in column "O"
If count Then
With ThisWorkbook.Sheets("Main").Cells(Rows.count, "O").End(xlUp)
.Offset(1).Resize(count).Value = data
End With
End If