Currently through a VBA code I am able to move most recent files (after 10 files) to another folder successfully. However, I have a complex situation and I have tried a lot but could not find any solution in VBA up till now. I would like to ask if there is any solution where if any of the file saved/comes in Source folder it should move after 2 hours to Destination folder.
E.g. A file name North_west saved/comes in Source folder at 10:00 AM therefore it should move to Destination at 12:00 PM (i.e. after 2 hours).
Similarly if another file was saved at 10:10 AM it should move to destination folder at 12:10 PM (exactly after two times) and so on this means for each file it is to check the computer time and execute/move after two hours. and if there are no files in the folder the code should keep checking after every 3 to 5 minutes.
Users saves numerous files with different file names and formats (specifically .txt .xml and .pdf)
Is there any solution regarding this, please kindly help.
the current code I have is.
Sub MostRecentFyles_1062357()
Dim oFSO As Object, oFSOFolder As Object, oFSOFile As Object
Dim sFilePath As String, sFilePath2 As String
Dim arr() As Variant
Dim i As Long, kounter As Long
i = 1
kounter = 0
sFilePath = "E:\Source\"
sFilePath2 = "E:\Destination\"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFSOFolder = oFSO.GetFolder(sFilePath)
kounter = oFSOFolder.Files.Count
If kounter < 11 Then Exit Sub
ReDim arr(1 To kounter, 1 To 2)
For Each oFSOFile In oFSOFolder.Files
arr(i, 1) = oFSOFile.Name
arr(i, 2) = FileDateTime(oFSOFile)
i = i + 1
Next oFSOFile
arr = SortArrayZtoA(arr)
For i = 5 To UBound(arr)
oFSO.movefile Source:=sFilePath & arr(i, 1), Destination:=sFilePath2 & arr(i, 1)
Next i
Set oFSOFile = Nothing
Set oFSOFolder = Nothing
Set oFSO = Nothing
Erase arr
End Sub
Function SortArrayZtoA(arr As Variant)
Dim i As Long, j As Long, n As Long
Dim Temp
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If CDate(arr(i, 2)) < CDate(arr(j, 2)) Then 'change less than symbol to greater than to sort A to Z
For n = LBound(arr, 2) To UBound(arr, 2)
Temp = arr(j, n)
arr(j, n) = arr(i, n)
arr(i, n) = Temp
Next n
End If
Next j
Next i
SortArrayZtoA = arr
End Function
regards
You can try to have the code to be run on a timer every x minutes. Check out Do Events concerning other running code, or let the timercode run from a seperate workbook or powershell/vbs code.
Related
I started VBA - programming 2 days ago and I'm having efficiency problems given my limited knowledge of VBA and EXCEL.
I'm moving data from .CSV to .xlsm files. The .CSV file i receive is structured as
SHEET;COL;ROW;VALUE.
This .CSV is then read to a multidimension array and populates an excel file withwb.Worksheets(ARRAY(i, SHEET)).Cells(R,C) = ARRAY(i, VALUE)
To my understanding, applying the array to a range of cells does not work, as there is no continuous surface to which i'm sending each individual .csv row.
What i've tried most of it can be seen below. I believe a big issue i'm having is the pass-through between VBA -> EXCEL for each .CSV row. Is there any way this can be done by bulk instead?
All types of comments about efficiency and general how-to in VBA is greatly appreciated!
Option Explicit
Private Sub imp_Data()
'----------------------------File Dialog for data input-----------------
Dim Valarr As Variant
Dim fullpath As String
Dim CSVSHEET As Integer, CSVCOL As Integer, CSVROW As Integer, CSVVALUE As Integer
fullpath = [YOUR TEST FILE.CSV]
'----------------------------Read rawdata----------------------------
Dim RawData As String
Open fullpath For Binary As #1
RawData = Space$(LOF(1))
Get #1, , RawData
Close #1
'----------------------------Split rawdata into array-------------------
Dim r As Long, Nrow As Long, Ncol As Long
Dim c As Integer
Dim lineArr As Variant, cellArr As Variant
If Len(RawData) > 0 Then
'Split each row in CSV to str array
lineArr = Split(Trim$(RawData), vbCrLf)
'Dim final array
Nrow = UBound(lineArr) + 1
Ncol = UBound(Split(lineArr(0), ";")) + 1
ReDim Valarr(1 To Nrow, 1 To Ncol)
'Split each col on delimiter ";"
For r = 1 To Nrow
If Len(lineArr(r - 1)) > 0 Then
cellArr = Split(lineArr(r - 1), ";")
For c = 1 To Ncol
Valarr(r, c) = cellArr(c - 1)
Next c
End If
Next r
Else
Debug.Print "No data read"
' do more stuff
End If
'----------------------------Read Table positions-----------------------
Dim i As Integer
For i = 1 To Ncol
If UCase(Valarr(1, i)) = "SHEET" Then
CSVSHEET = i
ElseIf UCase(Valarr(1, i)) = "COL" Then
CSVCOL = i
ElseIf UCase(Valarr(1, i)) = "ROW" Then
CSVROW = i
ElseIf UCase(Valarr(1, i)) = "VALUE" Then
CSVVALUE = i
End If
Next i
'Turn off calculation and screen update for efficiency
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'--------------------------------------------Send data to Cells----------
Dim L As Long
Dim wb As Workbook
Set wb = ThisWorkbook
L = UBound(Valarr, 1) - LBound(Valarr, 1) + 1
For i = 2 To L
If IsEmpty(Valarr(i, 1)) = 0 Then
wb.Worksheets(Valarr(i, CSVSHEET)).Cells(Valarr(i, CSVROW), Valarr(i, CSVCOL)) = Valarr(i, CSVVALUE)
End If
Next i
'Release ValArr memory
ReDim Valarr(0)
Erase Valarr
'Reapply calculation/screen update
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
From tests with 1 million rows it takes 14 seconds to read data to array and 5+ minutes to move the data to their designated cell. So the issue in the code below is (what i believe)
For i = 2 To L
If IsEmpty(Valarr(i, 1)) = 0 Then
wb.Worksheets(Valarr(i, CSVSHEET)).Cells(Valarr(i, CSVROW), Valarr(i, CSVCOL)) = Valarr(i, CSVVALUE)
End If
Next i
I want to randomly select 50 rows from one sheet and pasting them in a separate workbook for data sampling. I don't know how to do it because first, I'm new to VBA, I want to learn something new and second, I tried searching this on Google but no accurate answer found.
So what's on my mind is this:
I'll get first the number of rows in that worksheet. I've already
done it with this one line of code:
CountRows = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Get a random number from 1 to CountRows uniquely. The random numbers should be incremental (1,5,7,20,28,30,50 and no backward counting). Then grab that row, create a new workbook if not yet open and paste it there.
How can I achieve this process? I have no idea how to start this.
First, generate an array of 50 unique numbers between 1 and CountRows, using this routine:
' Generate a sorted array(0 to count-1) numbers between a and b inclusive
Function UniqueRandom(ByVal count As Long, ByVal a As Long, ByVal b As Long) As Long()
Dim i As Long, j As Long, x As Long
ReDim arr(b - a) As Long
Randomize
For i = 0 To b - a: arr(i) = a + i: Next
If b - a < count Then UniqueRandom = arr: Exit Function
For i = 0 To b - a 'Now we shuffle the array
j = Int(Rnd * (b - a))
x = arr(i): arr(i) = arr(j): arr(j) = x ' swap
Next
' After shuffling the array, we can simply take the first portion
ReDim Preserve arr(0 To count - 1)
'sorting, probably not necessary
For i = 0 To count - 1
For j = i To count - 1
If arr(j) < arr(i) Then x = arr(i): arr(i) = arr(j): arr(j) = x ' swap
Next
Next
UniqueRandom = arr
End Function
Now you can use the above routine to generate random, unique and sorted indexes and copy the corresponding rows. Here's an example:
Sub RandomSamples()
Const sampleCount As Long = 50
Dim lastRow As Long, i As Long, ar() As Long, rngToCopy As Range
With Sheet1
lastRow = .Cells(.Rows.count, "A").End(xlUp).row
ar = UniqueRandom(sampleCount, 1, lastRow)
Set rngToCopy = .Rows(ar(0))
For i = 1 To UBound(ar)
Set rngToCopy = Union(rngToCopy, .Rows(ar(i)))
Next
End With
With Workbooks.Add
rngToCopy.Copy .Sheets(1).Cells(1, 1)
.SaveAs ThisWorkbook.path & "\" & "samples.xlsx"
.Close False
End With
End Sub
Following code will do what you need.
Sub Demo()
Dim lng As Long
Dim tempArr() As String
Dim srcWB As Workbook, destWB As Workbook
Dim rng As Range
Dim dict As New Scripting.Dictionary
Const rowMax As Long = 100 'maximum number of rows in source sheet
Const rowMin As Long = 1 'starting row number to copy
Const rowCopy As Long = 50 'number of rows to copy
Dim intArr(1 To rowCopy) As Integer, rowArr(1 To rowCopy) As Integer
Set srcWB = ThisWorkbook
'get unique random numbers in dictionary
With dict
Do While .Count < rowCopy
lng = Rnd * (rowMax - rowMin) + rowMin
.Item(lng) = Empty
Loop
tempArr = Split(Join(.Keys, ","), ",")
End With
'convert random numbers to integers
For i = 1 To rowCopy
intArr(i) = CInt(tempArr(i - 1))
Next i
'sort random numbers
For i = 1 To rowCopy
rowArr(i) = Application.WorksheetFunction.Small(intArr, i)
If rng Is Nothing Then
Set rng = srcWB.Sheets("Sheet1").Rows(rowArr(i))
Else
Set rng = Union(rng, srcWB.Sheets("Sheet1").Rows(rowArr(i)))
End If
Next i
'copy random rows, change sheet name and destination path as required
Set destWB = Workbooks.Add
With destWB
rng.Copy destWB.Sheets("Sheet1").Range("A1")
.SaveAs Filename:="D:\Book2.xls", FileFormat:=56
End With
End Sub
Above code uses Dictionary so you have to add reference to Microsoft Scripting Runtime Type Library. In Visual Basic Editor, go to Tools->References and check "Microsoft Scripting Runtime" in the list.
Let me know if anything is not clear.
This the code I am trying to run:
Option Explicit
Sub Test()
'-------------Declarations-------------------
Dim FinalRow, Sum As Long
Dim i, j, l, d, k, count As Integer
Dim custID(), amtPur() As Long
Dim ws As Worksheet
Set ws = Sheets("Data")
FinalRow = ws.Range("B90000").End(xlUp).Row
j = 0
'-------------Get All the Data-------------------
With ws
For i = 4 To FinalRow
custID(j) = ws.Range("B" & i).Value 'Error Here
amtPur(j) = ws.Range("C" & i).Value 'Error Here
j = j + 1
Next i
End With
'-------------Match it and present the output----
l = 4
Dim wk As Worksheet
Set wk = Sheets("Results")
With wk
For j = 0 To FinalRow
Sum = amtPur(j)
'For the first iteration
If j = 0 Then
For k = j + 1 To FinalRow
If custID(j) = custID(k) Then
Sum = amtPur(k) + Sum
Else: End If
Next k
wk.Range("A" & 3).Value = custID(j).Value
wk.Range("B" & 3).Value = Sum
Else: End If
'For the rest iterations
count = 0
d = j
Do While (d >= 0)
If custID(d) = custID(j) Then
count = count + 1
Else: End If
d = d - 1
Loop
If count <= 1 Then 'Check if instance was already found
For k = j + 1 To FinalRow
If custID(j) = custID(k) Then
Sum = amtPur(k) + Sum
Else: End If
Next k
wk.Range("A" & l).Value = custID(j).Text
wk.Range("B" & l).Value = Sum
l = l + 1
End If
Next j
End With
End Sub
but unfortunately am getting:
Subscript out of Range - Run time error 9
when I try to run it.
While you have declared your custID() and amtPur() arrays, they need to be initialised using ReDim statements before you can use them. In your case you will want to ReDim Preserve to retain values already stored in the arrays during prior loops:
Sub Test()
'-------------Declarations-------------------
Dim FinalRow, Sum As Long
Dim i As Integer
j As Integer
l As Integer
d As Integer
k As Integer
count As Integer
Dim custID() As Long, amtPur() As Long
Dim ws As Worksheet
Set ws = Sheets("Data")
FinalRow = ws.Range("B90000").End(xlUp).Row
j = 0
'-------------Get All the Data-------------------
With ws
For i = 4 To 100
ReDim Preserve custID(0 To j)
ReDim Preserve amtPur(0 To j)
custID(j) = ws.Range("B" & i).Value 'Error Here
amtPur(j) = ws.Range("C" & i).Value 'Error Here
j = j + 1
Next i
End With
End Sub
Hmm, seems a little harsh that this question has been downvoted. You're clearly new to VBA and it does seem that you've given this a fair go. I admire people who learn through trial and error - it's certainly more than many first posters do - so I'd like to give you a pretty full answer with a bit of the theory behind it:
Dim - as mentioned, declare each type. Avoid names that are similar to existing functions, like sum.
If you declare your 'read' variable as a variant, you can read the data from the worksheet with just one line and the array will be dimensioned for you. You can also acquire custID and amtPur in the same array. I've given you an example of this in the code below in a variable called custData. Be aware that these arrays have a base of 1 rather than 0.
Your With blocks are redundant. These are meant to save you repeating the object each time you access its properties. In your code you repeat the object. I'm not a huge fan of With blocks but I've put a sample in your code so you can see how it works.
Your If ... Else ... End If blocks are a bit muddled. The logic should be If (case is true) Then do some code Else case is false, so do some other code End If. Again, I've tried to re-write your code to give you examples of this.
You are confusing looping through a Range and looping through an Array. In your code you have set the limits of the Range as 4 - FinalRow. However, this does not mean your arrays have been set to the same dimensions. Most likely, your arrays start from 0 and go to FinalRow - 4. You need to be clear about these dimensions before looping.
As Mark Fitzgerald mentions, you need to dimension your array before using it. If it's an initial dimension then you could just use Redim. If you want to increase the array's dimension whilst retaining existing values then use Redim Preserve. I've tried to give you an example of both in the code below.
Okay, so onto your code...
With the looping, array size and If mistakes, it's rather difficult to see what you're trying to do. I think you might be trying to read all the customer IDs, writing them into a unique list and then summing all the values that match each ID. The code below does that. It's not the quickest or best way, but I've tried to write the code so that you can see how each of the errors above should work. I guess it doesn't matter if I'm up the wrong path as the main aim is to give you an idea of how to manage arrays, loops and Ifs. I hope your custID and amtPur are genuinely Longs - if, for example, amtPur stands for 'amount purchased' and is, in fact, a decimal number then this code will throw and error, so make sure your values and declarations are of the same type. Your commenting etiquette is a little esoteric but I've still followed it.
Good luck with your project and keep at it. I hope this helps you:
'-------------Declarations-------------------
Dim dataSht As Worksheet
Dim resultsSht As Worksheet
Dim custData As Variant
Dim uniqueIDs() As Long
Dim summaryData() As Long
Dim counter As Integer
Dim isUnique As Boolean
Dim rng As Range
Dim i As Integer
Dim j As Integer
'-------------Get All the Data-------------------
Set dataSht = ThisWorkbook.Sheets("Data")
Set resultsSht = ThisWorkbook.Sheets("Results")
With dataSht
Set rng = .Range(.Cells(4, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Resize(, 2)
End With
custData = rng.Value2 'writes worksheet to variant array
'-------------Loop through the data to find number of unique IDs----
For i = 1 To UBound(custData, 1)
isUnique = True
If i = 1 Then
'First iteration so set the counter
counter = 0
Else
'Subsequent iterations so check for duplicate ID
For j = 1 To counter
If uniqueIDs(j) = custData(i, 1) Then
isUnique = False
Exit For
End If
Next
End If
'Add the unique ID to our list
If isUnique Then
counter = counter + 1
ReDim Preserve uniqueIDs(1 To counter)
uniqueIDs(counter) = custData(i, 1)
End If
Next
'-------------Aggregate the amtPur values----
ReDim summaryData(1 To counter, 1 To 2)
For i = 1 To counter
summaryData(i, 1) = uniqueIDs(i)
'Loop through the data to sum the values for the customer ID
For j = 1 To UBound(custData, 1)
If custData(j, 1) = uniqueIDs(i) Then
summaryData(i, 2) = summaryData(i, 2) + custData(j, 2)
End If
Next
Next
'-----------Outpute the results to the worksheet----
Set rng = resultsSht.Cells(4, 1).Resize(counter, 2)
rng.Value = summaryData
I have the following set of code:
For loopCounter = 2 To endRow
Dim item As Variant
Dim lineArray()
Dim myString As String
myString = Cells(loopCounter, 3).Value
ReDim lineArray(1 To endColumn)
If Not (Left(myString, 1) = "P" Or Left(myString, 1) = "I" Or myString = "RESW" Or myString = "REPC") Then
For x = 1 To endColumn
lineArray(x) = dataArray(loopCounter, x)
Next x
itemCollection.Add lineArray
End If
Next loopCounter
For the purpose of keeping this question short and to the point, I have a bunch of excel worksheets that contains hundreds of rows of data. To make a long story short, the code above add items from the worksheet to the collection, but it's adding every row (minus the conditions I set - if statement). However, I only want to add a fix amount of items to the collection, 15. I can't seem to figure it out and haven't found any help online.
My question for help is, does anyone know how I can make it that once 15 items are added to the collection it will exit out of the loop and finish the rest of the subroutine?
I purposely didn't add the whole code because it's quite lengthy and not necessary.
Thank you.
Sure thing, just check on the collection.Count > 14 then exit for
For loopCounter = 2 To endRow
Dim item As Variant
Dim lineArray()
Dim myString As String
myString = Cells(loopCounter, 3).Value
ReDim lineArray(1 To endColumn)
If Not (Left(myString, 1) = "P" Or Left(myString, 1) = "I" Or myString = "RESW" Or myString = "REPC") Then
For x = 1 To endColumn
lineArray(x) = dataArray(loopCounter, x)
Next x
itemCollection.Add lineArray
if itemCollection.Count = 15 then exit for
End If
Next loopCounter
if it would have been an array, then use if UBOUND(array) = 14 then exit for
I am a teacher and I have been making a number of multiple choice tests for students using Microsoft Word. Is there a way for me to automatically shuffle the questions so that I can have multiple versions of the test without needing to copy and paste the questions around my test?
Looking online I found a one solution posted by Steve Yandl in which he used macro after putting each question on a separate row in a table. I am trying to get his macro to work but it has and error. I know next to nothing about coding, so I am stuck. Here is his code:
Sub ShuffleQuestions()
Dim Tmax As Integer
Dim strCell As String
Dim strQ As Variant
Dim strText As String
Dim I As Integer
Dim Z As Integer
Dim intQsLeft As Integer
Dim rndQ As Integer
Dim Q As Integer
Dim vArray As Variant
Dim strNew As String
Set objDict = CreateObject("Scripting.Dictionary")
Tmax = ThisDocument.Tables(1).Rows.Count
For I = 1 To Tmax
strCell = ThisDocument.Tables(1).Cell(I, 1).Range.Text
strQ = Left(strCell, Len(strCell) - 1)
objDict.Add strQ, strQ
Next I
ReDim arrQs(I - 1)
intQsLeft = I - 2
Z = 0
Do While intQsLeft = 0
Randomize
rndQ = Int((intQsLeft + 1) * Rnd)
intQsLeft = intQsLeft - 1
vArray = objDict.Items
strText = vArray(rndQ)
arrQs(Z) = strText
Z = Z + 1
objDict.Remove strText
Loop
For Q = 1 To Tmax
strNew = arrQs(Q - 1)
strNew = Left(strNew, Len(strNew) - 1)
ThisDocument.Tables(1).Cell(Q, 1).Range.Text = strNew
Next Q
End Sub
The error message I get says "run time error 5941 the requested member of the collection does not exist"
When I choose the 'Debug' button it brings me to the line of code in the macro that says "Tmax = ThisDocument.Tables(1).Rows.Count"
Ultimately I just want to reorder the questions, but I would be delighted if there was also a way to reorder my multiple choice options for each question.
Does your document have a table?
Where did you put the sub (ShuffleQuestions)?
Are you sure you added it to your document and didn't add it to the document template (probably normal).
If, after running the code, reaching the error and clicking debug, you highlight ThisDocument.Tables, right clicking on the highlighted text and select "Add Watch" from the popup menu you should be able to see if ThisDocument.Tables contains any data.
I suspect it will be empty. It will be empty if:
You haven't added a table to your document
You have added the sub to normal.dot in which case ThisDocument will refer to the normal template and not the document you are actually editing.
So, the solution is either:
Make sure your sub is in the document you are editing (and not the document template)
That you have a table in your document.
There are also some programming errors in the sub ShuffleQuestions (e.g. Do While intQsLeft = 0 should be something like Do While intQsLeft > 0).
The following code works (and is a lot simpler):
Sub ShuffleQuestions()
Dim numberOfRows As Integer
Dim currentRowText As String
Dim I As Integer
Dim doc As Document
Set doc = ActiveDocument
'Find the number of rows in the first table of the document
numberOfRows = doc.Tables(1).Rows.Count
'Initialise (seed) the random number generator
Randomize
'For each row in the table
For I = 1 To numberOfRows
'Find a new row number (any row in the table)
newRow = Int(numberOfRows * Rnd + 1)
'Unless we're not moving to a new row
If newRow <> I Then
'Get the current row text
currentRowText = CleanUp(doc.Tables(1).Cell(I, 1).Range.Text)
'Overwrite the current row text with the new row text
doc.Tables(1).Cell(I, 1).Range.Text = CleanUp(doc.Tables(1).Cell(newRow, 1).Range.Text)
'Put the current row text into the new row
doc.Tables(1).Cell(newRow, 1).Range.Text = currentRowText
End If
Next I
End Sub
Function CleanUp(value As String) As String
'Remove control characters from the end of the string (the cell text has a 'BELL' character and CR at the end)
While (Len(value) > 0 And Asc(Right(value, 1)) < 32)
value = Left(value, Len(value) - 1)
Wend
CleanUp = value
End Function
For those who wants to randomize all the paragraphs in a document.
To make it work, put your cursor at the end of your document with no selections.
Sub ran_para()
n = ActiveDocument.Paragraphs.Count
ReDim a(1 To 2, 1 To n)
Randomize
For i = 1 To n
a(1, i) = Rnd
a(2, i) = i
Next
For i = 1 To n - 1
For j = i + 1 To n
If a(1, j) > a(1, i) Then
t = a(2, i)
a(2, i) = a(2, j)
a(2, j) = t
End If
Next
Next
'Documents.Add
For i = 1 To n
Set p = ActiveDocument.Paragraphs.Add
p.Range.Text = ActiveDocument.Paragraphs(a(2, i)).Range.Text
Next
End Sub