Related
I have an output excel file from another macro which has multiple sheets (named 100,101,102... etc.) Sheet numbers will vary depending on prior macro's output.
Also there is a sheet named sheet1 which has info about how many random rows should be selected from 100,101,102... etc.
I tried to merge/combine what i could find from similar macros but i guess the loop part is way over my head.
I will run the macro from another "main" excel. which will open related output xls.
Then it will lookup for random rows amount from sheet1 and then select that number of random rows in related sheet and move to next sheet. (I'm getting the correct amount from lookup (used index match))
But for randomized part i was not able to make it work for multiple sheets.
It does not matter if it selects and colors the rows or copies and pastes them to another sheet/wb. Both is ok, but I need to automate this process since i have so much data waiting.
The macro i have managed so far is below, since I'm a newbie there may be unrelated or unnecessary things.
Is it possible?
Sub RANDOM()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Worksheet
Dim Durat As Long
StartTime = Now()
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
Dim SheetN As Integer
Dim I As Long
FPath = ThisWorkbook.Path
Set mvn = Workbooks.Open(FileName:=ActiveWorkbook.Path & "\" &
Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value
& " Muavinbol" & ".xls")
SheetN = mvn.Worksheets.Count
Set SampleS = mvn.Sheets("Sheet1")
For Each Sh In mvn.Worksheets
Sh.Activate
If Sh.Name <> "Sheet1" Then
Dim lookupvalue As Integer
Dim ranrows As Integer
Dim randrows As Integer
lookupvalue = Cells(1, 1).Value
ranrows = Application.WorksheetFunction.Index(mvn.Sheets("Sheet1")_
.Range("S1:S304"), Application.WorksheetFunction.Match(lookupvalue,
mvn.Sheets("Sheet1").Range("$D$1:$D$304"), 0))
'MsgBox lookupvalue & " " & ranrows
End If
Next Sh
Durat = Round((Now() - StartTime) * 24 * 60 * 60, 0)
'MsgBox Durat & " seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Here is an example (i have integrated some code, adapted from other places, and added the references in to the code itself) I would welcome feedback from other users and can refine.
Sheet1 has the number of rows to return and the sheet names (i have used a short list)
The other sheets have some random data e.g. Sheet2
The code reads the sheet names into one array and the number of rows to randomly choose from each sheet into another array.
It then loops the sheets, generates the number of required random rows by selecting between the first and the start row in the sheet (this currently doesn't have error handling in case specified number of random rows exceeds available number ,but then could set numRows to lastRow. Union is used to collect these for the given sheet and they are copied to the next available row in the target sheet of another workbook. Union can't be used across worksheets sadly so a workaround has to be found, i chose this copy for each worksheet.
I have made some assumptions about where to copy from and to but have a play. I have also left some of your code in and currently set mnv = ThisWorkbook and the workbook to copy to is called otherWorkbook. Yours may be differently named and targeted but this was aimed at showing you a process for generating numbers and copying them in a loop.
Have used a function by Rory to test if the worksheet exists.
Example result:
Option Explicit
Public Sub RANDOM()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Worksheet
Dim Durat As Long
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
'Dim SheetN As Long
Dim i As Long
Dim otherWorkbook As Workbook
Dim targetSheet As Worksheet
Dim startTime As Date
Dim mnv As Workbook
Dim SampleS As Worksheet
startTime = Now()
FPath = ThisWorkbook.Path
'Set mvn = Workbooks.Open(Filename:=ActiveWorkbook.Path & "\" & Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value & " Muavinbol" & ".xls")
Set mnv = ThisWorkbook
Set otherWorkbook = Workbooks.Open("C:\Users\HarrisQ\Desktop\My Test Folder\Test.xlsx")
Set targetSheet = otherWorkbook.Sheets("TargetSheet")
Set SampleS = mnv.Worksheets("Sheet1")
Dim worksheetNames()
Dim numRandRows()
worksheetNames = SampleS.Range("$D$1:$D$3").Value
numRandRows = SampleS.Range("$S$1:$S$3").Value
Dim copyRange As Range
Dim currSheetIndex As Long
Dim currSheet As Worksheet
Dim selectedRows As Range
For currSheetIndex = LBound(worksheetNames, 1) To UBound(worksheetNames, 1)
If WorksheetExists(CStr(worksheetNames(currSheetIndex, 1))) Then
Set currSheet = mnv.Worksheets(worksheetNames(currSheetIndex, 1))
With currSheet
Dim firstRow As Long
Dim lastRow As Long
Dim numRows As Long
firstRow = GetFirstLastRow(currSheet, 1)(0) 'I am using Column A (1) to specify column to use to find first and last row.
lastRow = GetFirstLastRow(currSheet, 1)(1)
numRows = numRandRows(currSheetIndex, 1)
Set selectedRows = RandRows(currSheet, firstRow, lastRow, numRows) 'Union cannot span different worksheets so copy paste at this point
Dim nextTargetRow As Long
If IsEmpty(targetSheet.Range("A1")) Then
nextTargetRow = 1
Else
nextTargetRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row + 1
End If
selectedRows.Copy targetSheet.Cells(nextTargetRow, 1)
Set selectedRows = Nothing
End With
End If
Next currSheetIndex
Durat = Round((Now() - startTime) * 24 * 60 * 60, 0)
'MsgBox Durat & " seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Function RandRows(ByRef currSheet As Worksheet, ByVal firstRow As Long, ByVal lastRow As Long, ByVal numRows As Long) As Range
'http://www.ozgrid.com/VBA/RandomNumbers.htm
Dim iArr As Variant
Dim selectedRows As Range
Dim i As Long
Dim r As Long
Dim temp As Long
Application.Volatile
ReDim iArr(firstRow To lastRow)
For i = firstRow To lastRow
iArr(i) = i
Next i
For i = lastRow To firstRow + 1 Step -1
r = Int(Rnd() * (i - firstRow + 1)) + firstRow
temp = iArr(r)
iArr(r) = iArr(i)
iArr(i) = temp
Next i
Dim currRow As Range
For i = firstRow To firstRow + numRows - 1
Set currRow = currSheet.Cells.Rows(iArr(i))
If Not selectedRows Is Nothing Then
Set selectedRows = Application.Union(selectedRows, currRow)
Else
Set selectedRows = currRow
End If
Next i
If Not selectedRows Is Nothing Then
Set RandRows = selectedRows
Else
MsgBox "No rows were selected for copying"
End If
End Function
Private Function GetFirstLastRow(ByRef currSheet As Worksheet, ByVal colNum As Long) As Variant
'colNum determine which column you will use to find last row
Dim startRow As Long
Dim endRow As Long
endRow = currSheet.Cells(currSheet.Rows.Count, colNum).End(xlUp).Row
startRow = FirstUsedCell(currSheet, colNum)
GetFirstLastRow = Array(startRow, endRow)
End Function
Private Function FirstUsedCell(ByRef currSheet As Worksheet, ByVal colNum As Long) As Long
'Finds the first non-blank cell in a worksheet.
'https://www.excelcampus.com/library/find-the-first-used-cell-vba-macro/
Dim rFound As Range
On Error Resume Next
Set rFound = currSheet.Cells.Find(What:="*", _
After:=currSheet.Cells(currSheet.Rows.Count, colNum), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
If rFound Is Nothing Then
MsgBox currSheet & ":All cells are blank."
End
Else
FirstUsedCell = rFound.Row
End If
End Function
Function WorksheetExists(sName As String) As Boolean
'#Rory https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists
WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function
Since QHarr's code needed to have all worksheet names should exist in the workbook did not work for me in the end. But with merging it some other project's function i made it work.
Opens an output xlsx file in same folder,
Index&Match to find the random rows amount
loop through all sheets with random function
then paste all randomized rows into Sheet named RASSAL
It may be unefficient since I really dont have much info on codes, but guess i managed to modify it into my needs.
Open to suggestions anyway and thanks to #QHarr very much for His/Her replies.
Sub RASSALFNL()
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Dim Durat As Long
startTime = Now()
Dim Sht As Worksheet
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
Dim SheetN As Long
Dim i As Long
Dim lookupvalue As Long
Dim indexrange As Range
Dim matchrange As Range
Dim ranrows As Long
Dim firstRow As Long
Dim lastRow As Long
Dim numRows As Long
Dim sayf As String
Dim nextTargetRow As Long
Dim Rassal As Worksheet
Dim rngToCopy As Range
Dim sampleCount As Long
Dim ar() As Long
Dim total As Long
Dim rowhc As Long
FPath = ThisWorkbook.Path
Set mvn = Workbooks.Open(FileName:=ActiveWorkbook.Path & "\" &
Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value
& " Muavinbol" & ".xlsx")
SheetN = mvn.Worksheets.count
Set SampleS = mvn.Sheets("Sheet1")
Set Rassal = Worksheets.Add
Rassal.Name = "RASSAL"
Set indexrange = SampleS.Range("$S$8:$S$304")
Set matchrange = SampleS.Range("$D$8:$D$304")
mvn.Activate
For Each Sht In mvn.Worksheets
Sht.Activate
If Sht.Name = "Sheet1" Or Sht.Name = "Sayfa1" Or Sht.Name = "RASSAL"
Then
'do nothing
Else
lookupvalue = Sht.Cells(1, 1).Value
ranrows = Application.WorksheetFunction.Index(indexrange,
Application.WorksheetFunction.Match(lookupvalue, matchrange, 0))
With Sht
firstRow = GetFirstLastRow(Sht, 1)(0)
lastRow = GetFirstLastRow(Sht, 1)(1)
numRows = ranrows
sayf = Sht.Name
'MsgBox sayf & " " & firstRow & " " & lastRow & " " &
ranrows
If numRows = 0 Then
'do nothing
Else
ar = UniqueRandom(numRows, firstRow, lastRow)
Set rngToCopy = .Rows(ar(0))
For i = 1 To UBound(ar)
Set rngToCopy = Union(rngToCopy, .Rows(ar(i)))
Next
If IsEmpty(mvn.Sheets("RASSAL").Range("A1")) Then
nextTargetRow = 1
Else
nextTargetRow =
mvn.Sheets("RASSAL").Cells(mvn.Sheets("RASSAL").Rows.count,
"A").End(xlUp).Row + 1
End If
rngToCopy.Copy Rassal.Cells(nextTargetRow, 1)
Set rngToCopy = Nothing
End If
End With
End If
Next Sht
rowhc = Rassal.Cells(Rows.count, 1).End(xlUp).Row
Durat = Round((Now() - startTime) * 24 * 60 * 60, 0)
MsgBox rowhc & " " & "random selections made in" & " " & Durat & "
seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Function GetFirstLastRow(ByRef Sht As Worksheet, ByVal colNum As
Long) As Variant
'colNum determine which column you will use to find last row
Dim firstRow As Long
Dim lastRow As Long
lastRow = Sht.Cells(Sht.Rows.count, colNum).End(xlUp).Row
firstRow = FirstUsedCell(Sht, colNum)
GetFirstLastRow = Array(firstRow, lastRow)
End Function
Private Function FirstUsedCell(ByRef Sht As Worksheet, ByVal colNum As
Long) As Long
Dim rFound As Range
On Error Resume Next
Set rFound = Sht.Cells.Find(What:="*", _
After:=Sht.Cells(Sht.Rows.count,
colNum), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
If rFound Is Nothing Then
'do Nothing MsgBox Sh & ":All cells are blank."
End
Else
FirstUsedCell = rFound.Row
End If
End Function
Function UniqueRandom(ByVal numRows 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
If numRows = 0 Then
ReDim Preserve arr(0)
Else
ReDim Preserve arr(0 To numRows - 1)
On Error Resume Next
End If
'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
Each month I get our sales report and it contains quantities of goods we sold along with product details, and I created a template using vba where user can specify a product and it can create a excel report for them.
However, I would like to expand/modify so if I have multiple excel reports instead of just one report. I would like excel to separate however many product codes I input or listed.
Now, I added a tab called list in my template which I can list the # of product codes (the 4 digit number, in column A) where vba should read from but I need help on modifying the codes so instead of asking the user, it reads the list instead. Secondly, since master file contains all of the products and I maybe just need 20 or 30 of them, I will need the vba codes to be flexible as possible.
The way i set it up, I am basically updating/copying new info from Master file into Monthly Template and re-saving Monthly Template as product codes product as of 9.1.2017 file.
Sub monthly()
Dim x1 As Workbook, y1 As Workbook
Dim ws1, ws2 As Worksheet
Dim LR3, LR5 As Long
Dim ws3 As Worksheet
Dim Rng3, Rng4 As Range
Dim x3 As Long
Set x1 = Workbooks("Master.xlsx")
Set y1 = Workbooks("Monthly Template.xlsm")
Set ws1 = x1.Sheets("Products")
Set ws2 = y1.Sheets("Products")
Set ws3 = y1.Sheets("List")
ws2.Range("A3:AA30000").ClearContents
ws1.Cells.Copy ws2.Cells
x1.Close True
LR5 = ws3.Cells(Rows.Count, "A").End(xlUp).Row
With y1.Sheets("List")
Range("A1:A32").Sort key1:=Range("A1"), Order1:=xlAscending
End With
LR3 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
Set Rng3 = ws2.Range("AC3:AC" & LR3)
Set Rng4 = ws3.Range("A1:A" & LR5)
For n = 3 To LR3
ws2.Cells(n, 29).FormulaR1C1 = "=LEFT(RC[-21], 4)"
Next n
With y1.Sheets("List")
j = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With ws2
l = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For i = 1 To j
For k = 3 To l
If Sheets("List").Cells(i, 1).Value = Sheets("Products").Cells(k, 29).Value Then
With Sheets("Output")
m = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Sheets("Output").Rows(m + 1).Value = Sheets("Products").Rows(k).Value
End If
Next k
Next i
Sheets("Output").Columns("AC").ClearContents
Dim cell As Range
Dim dict As Object, vKey As Variant
Dim Key As String
Dim SheetsInNewWorkbook As Long
Dim DateOf As Date
DateOf = DateSerial(Year(Date), Month(Date), 1)
With Application
.ScreenUpdating = False
SheetsInNewWorkbook = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
End With
Set dict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("List")
For Each cell In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
Key = Left(cell.Value, 4)
'Store an ArrayList in the Scripting.Dictionary that can be retrieved using the Product Key
If Not dict.exists(Key) Then dict.Add Key, CreateObject("System.Collections.ArrayList")
Next
End With
With Workbooks("Monthly Template.xlsm").Worksheets("Output")
For Each cell In .Range("H2", .Range("A" & .Rows.Count).End(xlUp))
Key = Left(cell.Value, 4)
'Add the Products to the ArrayList in the Scripting.Dictionary that is associated with the Product Key
If dict.exists(Key) Then dict(Key).Add cell.Value
Next
End With
For Each vKey In dict
If dict(vKey).Count > 0 Then
With Workbooks.Add
With .Worksheets(1)
.Name = "Products"
' .Range("A1").Value = "Products"
Workbooks("Monthly Template.xlsm").Worksheets("Output").Cells.Copy Worksheets(1).Cells
For Z = 1 To LR5
For x3 = Rng3.Rows.Count To 1 Step -1
If InStr(1, Rng3.Cells(x3, 1).Text, Workbooks("Monthly Template.xlsm").Worksheets("List").Cells(Z, 1).Text) = 0 Then
Rng3.Cells(x3, 1).EntireRow.Delete
End If
Next x3
Next Z
'.Range("A2").Resize(dict(vKey).Count).Value = Application.Transpose(dict(vKey).ToArray)
End With
.SaveAs Filename:=getMonthlyFileName(DateOf, CStr(vKey)), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close SaveChanges:=False
End With
End If
Next
With Application
.ScreenUpdating = True
.SheetsInNewWorkbook = SheetsInNewWorkbook
End With
End Sub
Function getMonthlyFileName(DateOf As Date, Product As String) As String
Dim path As String
path = ThisWorkbook.path & "\Product Reports\"
If Len(Dir(path, vbDirectory)) = 0 Then MkDir path
path = path & Format(DateOf, "yyyy") & "\"
If Len(Dir(path, vbDirectory)) = 0 Then MkDir path
path = path & Format(DateOf, "mmm") & "\"
If Len(Dir(path, vbDirectory)) = 0 Then MkDir path
getMonthlyFileName = path & "Product - " & Product & Format(DateOf, " mmm.dd.yyyy") & ".xlsx"
End Function
I seen no reason why to save copies of Monthly Template.xlsm. The OP's code simply creates a list on a worksheet and saves it to file. I might be some formatting missing that would normally get saved over from the Master File.
getMonthlyFileName(DateOf, Product) - creates a file path (Root Path\Year of Date\Month of Date\Product - Prodcut mmm.dd.yyyy.xlsx. In this way, the Product files can be stored in an easy to lookup structure.
Sub CreateMonthlyReports()
Dim cell As Range
Dim dict As Object, vKey As Variant
Dim Key As String
Dim SheetsInNewWorkbook As Long
Dim DateOf As Date
DateOf = DateSerial(Year(Date), Month(Date), 1)
With Application
.ScreenUpdating = False
SheetsInNewWorkbook = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
End With
Set dict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("List")
For Each cell In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
Key = Left(cell.Value, 4)
'Store an ArrayList in the Scripting.Dictionary that can be retrieved using the Product Key
If Not dict.exists(Key) Then dict.Add Key, CreateObject("System.Collections.ArrayList")
Next
End With
With Workbooks("Master.xlsx").Worksheets("Products")
For Each cell In .Range("H2", .Range("H" & .Rows.Count).End(xlUp))
Key = Left(cell.Value, 4)
'Add the Products to the ArrayList in the Scripting.Dictionary that is associated with the Product Key
If dict.exists(Key) Then dict(Key).Add cell.Value
Next
End With
For Each vKey In dict
If dict(vKey).Count > 0 Then
With Workbooks.Add
With .Worksheets(1)
.Name = "Products"
.Range("A1").Value = "Products"
.Range("A2").Resize(dict(vKey).Count).Value = Application.Transpose(dict(vKey).ToArray)
End With
.SaveAs FileName:=getMonthlyFileName(DateOf, CStr(vKey)), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close SaveChanges:=False
End With
End If
Next
With Application
.ScreenUpdating = True
.SheetsInNewWorkbook = SheetsInNewWorkbook
End With
End Sub
Function getMonthlyFileName(DateOf As Date, Product As String) As String
Dim path As String
path = ThisWorkbook.path & "\Product Reports\"
If Len(Dir(path, vbDirectory)) = 0 Then MkDir path
path = path & Format(DateOf, "yyyy") & "\"
If Len(Dir(path, vbDirectory)) = 0 Then MkDir path
path = path & Format(DateOf, "mmm") & "\"
If Len(Dir(path, vbDirectory)) = 0 Then MkDir path
getMonthlyFileName = path & "Product - " & Product & Format(DateOf, " mmm.dd.yyyy") & ".xlsx"
End Function
Try two loops for this, making sure you sort by the product in the main list to make this a little quicker.
Dim i as Long, j as Long, k as Long, l as Long, m as Long
With Sheets("List")
j = .Cells( .Rows.Count, 1).End(xlUp).Row
End With
With Sheets("Products")
l = .Cells( .Rows.Count, 1).End(xlUp).Row
End With
For i = 2 to j
For k = 2 to l
If Sheets("List").Cells(i,1).Value = Sheets("Products").Cells(k,1).Value Then
With Sheets("Output")
m = .Cells( .Rows.Count, 1).End(xlUp).Row
End With
Sheets("Output").Rows(m+1).Value = Sheets("Products").Rows(k).Value
End If
Next k
Next i
Edit
Will try to piecemeal something to give at least a lead to splitting into different sheets, rather than having one output sheet (this will not be tested, just free-coding):
Dim i as Long, j as Long, k as Long, l as Long, m as Long, n as String
With Sheets("List")
j = .Cells( .Rows.Count, 1).End(xlUp).Row
End With
With Sheets("Products")
l = .Cells( .Rows.Count, 1).End(xlUp).Row
End With
For i = 2 to j
n = Sheets("List").Cells(i,1).Value
Sheets.Add(After:=Sheets(Sheets.Count)).Name = n
Sheets(n).Cells(1,1).Value = n
Sheets(n).Rows(2).Value = Sheets("Products").Rows(1).Value
For k = 2 to l
With Sheets(n)
If .Cells(1,1).Value = Sheets("Products").Cells(k,1).Value Then
m = .Cells( .Rows.Count, 1).End(xlUp).Row
.Rows(m+1).Value = Sheets("Products").Rows(k).Value
End If
Next k
Next i
I don't know why some people doing VBA thinks declaring all the variables with weird names before a thousand lines of code is a good idea.........
Anyways..back to the question, I believe what you are trying to achieve is:
1) Specify a list whilst the code iterates through the list and filters the data based on the listed items.
2) Creates a workbook where the filtered the data is copied over.
3) saving the workbook to somewhere you'll specify, with a specific name.
So naturally, your programme access point should be the one that iterates through the specified list, which should be your main function.
Then inside main function you'll have a Sub that deals with whatever the product ID is, and then filters on your product ID, then copies the data into a newly created workbook.
Last step would be naming the new workbook and saving it close it.
So here is some code skeleton that hopefully will help you with creating the monthly reports. You'll have to write yourself how you want to copy the data from your master workbook to the destination workbook (it should be simple enough, just filter the source list and copy the results to the destination workbook, no dictionary nor arraylist is needed).
Sub main()
Dim rngIdx As Range
Set rngIdx = ThisWorkbook.Sheets("where your list is").Range("A1")
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
While (rngIdx.Value <> "")
Call create_report(rngIdx.Value)
Set rngIdx = rngIdx.Offset(1, 0)
Wend
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
Sub create_report(ByVal product_ID As String)
Dim dest_wbk As Workbook
Set dest_wbk = Workbooks.Add
Call do_whatever(ThisWorkbook, dest_wbk, product_ID)
dest_wbk.SaveAs getMonthlyFileName(some_date, product_ID)
dest_wbk.Close
End Sub
Sub do_whatever(source_wbk As Workbook, dest_wbk As Workbook, ByVal product_ID As String)
' this is the code where you copy from your master data to the destination workbook
' modify sheet names, formatting.......etc.
End Sub
I need a macro to split my data from one Excel file to few others. It looks like this:
UserList.xls
User Role Location
DDAVIS XX WW
DDAVIS XS WW
GROBERT XW WP
SJOBS XX AA
SJOBS XS AA
SJOBS XW AA
I need, to copy data like this:
WW_DDAVIS.xls
User Role
DDAVIS XX
DDAVIS XS
WP_GROBERT.xls
User Role
GROBERT XW
AA_SJOBS.xls
User Role
SJOBS XX
SJOBS XS
SJOBS XW
I need every user, to have his own file. The problem appeared when I was told that the files need to be filled using template (template.xls). Looks the same, but data in the source file starts in cell A2, and in the template file from cell A8.
To copy data without template I used this code:
Public Sub SplitToFiles()
' MACRO SplitToFiles
' Last update: 2012-03-04
' Author: mtone
' Version 1.1
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
'
' Note: Values in the column should be unique or sorted.
'
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
'
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.
Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created
iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
iFirstRow = iRow
Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path
If Dir(sFilePath + "\Split", vbDirectory) = "" Then
MkDir sFilePath + "\Split"
End If
'Turn Off Screen Updating Events
Application.EnableEvents = False
Application.ScreenUpdating = False
Do
' Get cell at cursor
Set rCell = osh.Cells(iRow, iCol)
sCell = Replace(rCell.Text, " ", "")
If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
' Skip condition met
Else
' Found new section
If iStartRow = 0 Then
' StartRow delimiter not set, meaning beginning a new section
sSectionName = rCell.Text
iStartRow = iRow
Else
' StartRow delimiter set, meaning we reached the end of a section
iStopRow = iRow - 1
' Pass variables to a separate sub to create and save the new worksheet
CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
iCount = iCount + 1
' Reset section delimiters
iStartRow = 0
iStopRow = 0
' Ready to continue loop
iRow = iRow - 1
End If
End If
' Continue until last row is reached
If iRow < iTotalRows Then
iRow = iRow + 1
Else
' Finished. Save the last section
iStopRow = iRow
CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
iCount = iCount + 1
' Exit
Exit Do
End If
Loop
'Turn On Screen Updating Events
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox Str(iCount) + " documents saved in " + sFilePath
End Sub
Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)
Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete
End Sub
Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
Dim ash As Worksheet ' Copied sheet
Dim awb As Workbook ' New workbook
' Copy book
osh.Copy
Set ash = Application.ActiveSheet
' Delete Rows after section
If iTotalRows > iStopRow Then
DeleteRows ash, iStopRow + 1, iTotalRows
End If
' Delete Rows before section
If iStartRow > iFirstRow Then
DeleteRows ash, iFirstRow, iStartRow - 1
End If
' Select left-topmost cell
ash.Cells(1, 1).Select
' Clean up a few characters to prevent invalid filename
sSectionName = Replace(sSectionName, "/", " ")
sSectionName = Replace(sSectionName, "\", " ")
sSectionName = Replace(sSectionName, ":", " ")
sSectionName = Replace(sSectionName, "=", " ")
sSectionName = Replace(sSectionName, "*", " ")
sSectionName = Replace(sSectionName, ".", " ")
sSectionName = Replace(sSectionName, "?", " ")
' Save in same format as original workbook
ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat
' Close
Set awb = ash.Parent
awb.Close SaveChanges:=False
End Sub
The problem in this one, is that I have no idea how to make name not DDAVIS.xls, but using WW_DDAVIS.xls (location_user.xls). Second problem - Use template. This code just copies whole workbook and erases all wrong data. All I need, is to copy value of the right data to this template.
Unfortunately I didn't find working code and I'm not so fluent in VBA to make it alone.
I tried other one, that worked only in half. It copied the template to every file and name it properly, but I couldn't figure out how to copy cells to the right files.
Option Explicit
Sub copyTemplate()
Dim lRow, x As Integer
Dim wbName As String
Dim fso As Variant
Dim dic As Variant
Dim colA As String
Dim colB As String
Dim colSep As String
Dim copyFile As String
Dim copyTo As String
Set dic = CreateObject("Scripting.Dictionary") 'dictionary to ensure that duplicates are not created
Set fso = CreateObject("Scripting.FileSystemObject") 'file scripting object for fiile system manipulation
colSep = "_" 'separater between values of col A and col B for file name
dic.Add colSep, vbNullString ' ensuring that we never create a file when both columns are blank in between
'get last used row in col A
lRow = Range("A" & Rows.Count).End(xlUp).Row
x = 1
copyFile = "c:\location\Template.xls" 'template file to copy
copyTo = "C:\location\List\" 'location where copied files need to be copied
Do
x = x + 1
colA = Range("G" & x).Value 'col a value
colB = Range("A" & x).Value ' col b value
wbName = colA & colSep & colB ' create new file name
If (Not dic.Exists(wbName)) Then 'ensure that we have not created this file name before
fso.copyFile copyFile, copyTo & wbName & ".xls" 'copy the file
dic.Add wbName, vbNullString 'add to dictionary that we have created this file
End If
Loop Until x = lRow
Set dic = Nothing ' clean up
Set fso = Nothing ' clean up
End Sub
sub test()
dim wb
dim temp
dim rloc
rloc= "result files location"
set wb =thisworkbook
set temp= workbook.open(template path)
' getting last row
lrow=wb.sheets(1).range("A1:A"&rows.count).end(xlup).row
icounter=0
for i=2 to lrow 'leaving out the header row
with wb.sheets(1)
if cells(i,1).value=cells(i,1).offset(1,1).value then
icounter=icounter+1
else
if icounter>0 then
range(cells(i,1):(cells(i,1).offset(-icounter,2)).copy
wb.sheet(8,1).pastespecial xlvalues
application.cutcopymode=false
filename=str(cells(i,1).value) & "_" & str(cells(i,3).value) & "".xls"
chdir rloc
temp.saveas(filename,xlworkbookdefault)
else
range(cells(i,1):cells(i,2)).copy
wb.sheets(8,1).pastespecial xlvalues
application.cutcopymode=false
filename=str(cells(i,1).value) & "_" & str(cells(i,3).value) & ".xls"
chdir rloc
temp.saveas(filename,xlworkbookdefault)
end if
end if
end with
next i
wb.close savechanges:=false
temp.close savechanges:=false
end sub
this might work. i haven't tested the code. its a bit crude. i am also just a beginner in vba. forgive me if it contains errors.
look at the logic. if its all you want create a code from scratch yourself.
#Sivaprasath V
Thanks, looks like it should work. I've changed it a little bit, to look better and to fix some issues
Sub test()
Dim wb
Dim temp
Dim rloc
rloc = "C:\LOCATION\result\"
Set wb = ThisWorkbook
Set temp = Workbooks.Open("C:\LOCATION\Template.xls")
' getting last row
lRow = wb.Sheets(1).Range("A1:A" & Rows.Count).End(xlDown).Row 'changed xlUp for xlDown
icounter = 0
For i = 2 To lRow 'leaving out the header row
With wb.Sheets(1)
Range("C2").Value = Cells(i, 1).Value
If Cells(i, 1).Value = Cells(i, 1).Offset(1, 0).Value Then 'changed offset from (1,1)
icounter = icounter + 1
Else
If icounter > 0 Then
Range(cells(i,1):(cells(i,1).offset(-icounter,7)).Copy 'error
wb.Sheet(8, 1).PasteSpecial xlValues
Application.CutCopyMode = False
Filename = Str(Cells(i, 1).Value) & "_" & Str(Cells(i, 3).Value) & ".xls"
ChDir rloc
temp.SaveAs Filename, xlWorkbookDefault
Else
Range(cells(i,1):cells(i,7)).Copy 'error
wb.Sheets(8, 1).PasteSpecial xlValues
Application.CutCopyMode = False
Filename = Str(Cells(i, 1).Value) & "_" & Str(Cells(i, 3).Value) & ".xls"
ChDir rloc
temp.SaveAs Filename, xlWorkbookDefault
End If
End If
End With
Next i
wb.Close savechanges:=False
temp.Close savechanges:=False
End Sub
I'm fighting with an error that i can't quite understand. In line:
Range(cells(i,1):(cells(i,1).offset(-icounter,7)).Copy
and this:
Range(cells(i,1):cells(i,7)).Copy
There is an error saying:
Compile error:
Expected: list separator or )
Can't figure out how to fix it. Code looks good for me.
#EDIT
Went around the error using new variable ("C" & i & ":" & "F" & i - icounter)
after some minor changes it worked, thanks :)
I have 24 Textbox in a word Document as shown in the picture Below:
Which I am trying to populate using the content from each cell from the below range in a worksheet as shown below:
Three Rows at a time: Because there are 24 textboxes so 3 Rows and 8 Columns will have 24 Cells each time:
I would then Save it with a unique name and Make New from the next 3 Rows:
Code:
Option Explicit
Sub TransferData()
Dim FRow As Long, i As Long, j As Long
Dim wk As Worksheet, wt As Worksheet
Dim Path As String, Folder As String, File As String, CandName As String
Set wt = Sheet2 'Temp
Set wk = Sheet1 'Main
FRow = wk.Range("D" & Rows.Count).End(xlUp).Row
wt.Cells.Clear
wk.Range("D6:K" & FRow).Copy
wt.Activate
wt.Range("A1").Select
wt.Paste
Application.CutCopyMode = False
wt.Columns.AutoFit
FRow = wt.Range("A" & Rows.Count).End(xlUp).Row
wt.Range("$A$1:$H$" & FRow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8), Header:=xlYes
'----------Deduping is Done Now Transferring Data from eXcel to Word---------------
Path = Trim(wk.Range("A6").Text)
Folder = Trim(wk.Range("A10").Text)
File = Trim(wk.Range("A14").Text)
Dim Rng As Range
Dim r As Long, ct As Long, col As Long
Dim wdApp As Word.Application, wdDoc As Word.Document
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdDoc = wdApp.Documents.Open(Path & "\" & Folder & "\" & File)
With wt
FRow = .Range("A" & Rows.Count).End(xlUp).Row
Set Rng = .Range("A2:G" & FRow)
End With
With Rng
r = 2
Do
Set wdDoc = wdApp.Documents.Open(Path & "\" & Folder & "\" & File)
CandName = Trim(.Range("A" & r).Text)
col = 0
For i = 1 To 24
If i Mod 9 = 0 Then
r = r + 1
col = 1
Else
col = col + 1
End If
wdDoc.Shapes("Text Box " & i).TextFrame.TextRange.Text = .Cells(r, col).Value
Next i
ActiveDocument.SaveAs Filename:=Path & "\" & Folder & "\" & "New Files\" & "_" & CandName & r
Loop Until .Range("A" & r).Text <> ""
End With
End Sub
What I don't know:
How to rename a textbox (manually or by code) in the word document so that in can be used in the macro.
Save the word document and Create New Word Doc with 24 TextBoxes so that they can be filled again.
For your request I've modified your code.
I couldn't test it myself, since there are variables that are not accessible to me (Path, Folder) so if does not compile and work, just look and what I've done near the end and try to modify yourself.
basically, after 3 lines I've instructed to save the current file as new, and open the 24-blank-textboxes file again, which will be saved again after 3 lines etc'...
BTW, you mentioned you wanted to change the name of a textBox, but there is nothing about it in your code. If you want to do it you will need to write us more code about it.
Option Explicit
Sub TransferData()
Dim FRow As Long, i As Long, j As Long
Dim wk As Worksheet, wt As Worksheet
Dim Path As String, Folder As String, File As String, CandName As String
Set wt = Sheet2 'Temp
Set wk = Sheet1 'Main
FRow = wk.Range("D" & Rows.Count).End(xlUp).Row
wt.Cells.Clear
wk.Range("D6:K" & FRow).Copy
wt.Activate
wt.Range("A1").Select
wt.Paste
Application.CutCopyMode = False
wt.Columns.AutoFit
FRow = wt.Range("A" & Rows.Count).End(xlUp).Row
wt.Range("$A$1:$H$" & FRow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5,
6, 7, 8), Header:=xlYes
'----------Deduping is Done Now Transferring Data from eXcel to Word-------
Path = Trim(wk.Range("A6").Text)
Folder = Trim(wk.Range("A10").Text)
File = Trim(wk.Range("A14").Text)
Dim Rng As Range
Dim r As Long, ct As Long, col As Long
Dim wdApp As Word.Application, wdDoc As Word.Document
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdDoc = wdApp.Documents.Open(Path & "\" & Folder & "\" & File)
With wt
FRow = .Range("A" & Rows.Count).End(xlUp).Row
Set Rng = .Range("A2:G" & FRow)
End With
With Rng
r = 2
Do
CandName = Trim(.Range("A" & r).Text)
col = 0
For i = 1 To 24
If i Mod 9 = 0 Then
r = r + 1
col = 1
Else
col = col + 1
End If
wdDoc.Shapes("Text Box " & i).TextFrame.TextRange.Text =_
.Cells(r, col).Value
Next i
if (r-2) mod 3 = 0 then
ActiveDocument.SaveAs Filename:=Path & "\" & Folder & "\" &_
"New Files\" & "_" & CandName & r
Set wdApp = Nothing
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wdApp = CreateObject("Word.Application")
End If
Set wdDoc = wdApp.Documents.Open(Path & "\" & Folder & "\" &_
File)
end if
Loop Until .Range("A" & r).Text <> ""
End With
End Sub
Code to rename textBox1 as textBox2:
ActiveDocument.Shapes("Text Box 1").Select
ActiveDocument.Shapes("Text Box 1").Name = "Text Box 2"
without first selecting the textBox (or any other shape for that matter) , you can't modify its name.
You've already done that in the code, just re-use the line:
Set wdDoc = wdApp.Documents.Open(Path & "\" & Folder & "\" & File)
..to open a new file and to start over. Make sure you close the documents which you don't need anymore, or you'll end up with 24 open documents. I don't think you need that.
INITIAL QUESTION
Why am I not able to open all (all three) matching workbooks?
Dropdown selection:
1A:1C = Company1 Company2 Company3
2A:2C = Version2 Version1 Version1
Only the first one (Company1, Version2) will open...
Sub OpenWorkbooks()
Dim ColumnIndex1 As Integer
Dim ColumnIndex2 As Integer
Dim ColumnIndex3 As Integer
Dim ColumnIndex4 As Integer
Dim ColumnIndex5 As Integer
Dim ColumnIndex6 As Integer
For ColumnIndex1 = 1 To 3
If Cells(1, ColumnIndex1).Value = "Company1" And Cells(2,
ColumnIndex1).Value = "Version1" Then
Workbooks.Open Filename:="D:\Company1\Version1.xlsx"
End If
Next ColumnIndex1
For ColumnIndex2 = 1 To 3
If Cells(1, ColumnIndex2).Value = "Company1" And Cells(2,
ColumnIndex2).Value = "Version2" Then
Workbooks.Open Filename:="D:\Company1\Version2.xlsx"
End If
Next ColumnIndex2
For ColumnIndex3 = 1 To 3
If Cells(1, ColumnIndex3).Value = "Company2" And Cells(2,
ColumnIndex3).Value = "Version1" Then
Workbooks.Open Filename:="D:\Company2\Version1.xlsx"
End If
Next ColumnIndex3
For ColumnIndex4 = 1 To 3
If Cells(1, ColumnIndex4).Value = "Company2" And Cells(2,
ColumnIndex4).Value = "Version2" Then
Workbooks.Open Filename:="D:\Company2\Version2.xlsx"
End If
Next ColumnIndex4
For ColumnIndex5 = 1 To 3
If Cells(1, ColumnIndex5).Value = "Company3" And Cells(2,
ColumnIndex5).Value = "Version1" Then
Workbooks.Open Filename:="D:\Company3\Version1.xlsx"
End If
Next ColumnIndex5
For ColumnIndex6 = 1 To 3
If Cells(1, ColumnIndex6).Value = "Company3" And Cells(2,
ColumnIndex6).Value = "Version2" Then
Workbooks.Open Filename:="D:\Company3\Version2.xlsx"
End If
Next ColumnIndex6
End Sub
I have just started using VBA (and StackOverflow).
Thank you.
FOLLOW-UP
# Dirk Reichel:
# All:
I have tried to expand Dirk's idea a bit (See below), and I'm trying to open 5 (or less) workbooks in sequence each time copying/pasting a specific range to the 'main2' sheet of the 'main' workbook.
It works fine unless I open fewer workbooks than the number of dropdown values that are being checked (I'm currently using 5 dropdown sets instead of the original 3: see top of page):
Sub ImportData()
Dim MainWorkbook As Workbook
Dim DataWorkbook As Workbook
Dim i As Long
Set MainWorkbook = ThisWorkbook
With MainWorkbook.ActiveSheet
For i = 2 To 6
If ActiveSheet.Cells(6, i).Value <> "" Then
Set DataWorkbook = Workbooks.Open("D:\ 'some folders' \" & .Cells(6,
i).Value & "-" & .Cells(10, 2) & "-" & .Cells(7, i).Value & ".xlsx")
DataWorkbook.Sheets("Sheet1").Range("C3:Q3").Copy
MainWorkbook.Sheets("Main2").Range("A" & i).PasteSpecial
On Error Resume Next
End If
Next i
End With
End Sub
I have used 3 of the (now) 5 dropdown menus, and only 1 workbook is currently being opened and copied...
You may try an easier script like this:
Sub OpenWorkbooks()
Dim i As Long
With ThisWorkbook.ActiveSheet
For i = 1 To 3
Workbooks.Open Filename:="D:\" & .Cells(1, i).Value & "\" & .Cells(2, i).Value & ".xlsx"
Next i
End With
End Sub
if your Cells do not have any "Workbook" and "Worksheet" they will do it with the active one (after opening the first workbook, all your Cells will refer to it and not to the orginal source)