Switching to Excel 2013 from Excel 2010,
When Sheet2 is inactive
The code
Worksheets("Sheet2").Rows("432:432").EntireRow.Hidden = False
gives Error
Unable to set the Hidden property of the Range class
But works fine when Sheet2 is the Active Sheet
In Excel 2010 , VBA had no problem hiding rows in InactiveSheets .
Is this a change in Excel 2013. If so, any fix.
EDIT:
Worksheets("Sheet2").Protect Password:="password", userinterfaceonly:=True Worksheets("Sheet2").Rows("2:2").EntireRow.Hidden = False
When setting userinterfaceonly option to true, VBA Code to hide row only works when the sheet is active
I can't recreate this error on a new 2013 Worksheet. But only when opening 2010 Excel app in 2013. Wonder If I am playing with any Settings here.
Sub MakeScript1()
application.ScreenUpdating = False
Sheets("Script1").Visible = True
ThisWorkbook.Sheets("Script1").Select
Dim x As Long, Z As Long, FF As Long, TextOut As String
Const OutputPath As String = "c:\temp\" '<==Note the trailing backslash
Const BaseFileName As String = "Script1"
Const StartColumn As Long = 1 'Assumed Column A
Const StartRow As Long = 1 'Assumed Row 1
For x = StartColumn + 1 To StartColumn + 1
TextOut = ""
For Z = StartRow To StartRow + 19
TextOut = TextOut & Cells(Z, StartColumn).Value & " " & Cells(Z, x).Value & vbNewLine
Next
FF = FreeFile
Open OutputPath & BaseFileName & ".vbs" For Output As #FF
Print #FF, TextOut
Close #FF
Next
ThisWorkbook.Sheets("Instructions").Select
Sheets("Script1").Visible = False
application.ScreenUpdating = True
End Sub
see how i did
Sheets("Script1").Visible = True
and then
Sheets("Script1").Visible = False
oops, my bad the above isnt what you wanted.
here try code from this:
Dim RowsToHide As Range
Dim RowHideNum As Integer
' Set Correct Start Dates for Billing in New File
Workbooks("----- Combined_New_Students_Updated.xlsx").Activate
Sheets("2015").Activate
StartDateLine1 = Format(START_DATE_1, "ww") - 1 ' Convert Start Date to Week Number
StartDateLine1 = (StartDateLine1 * 6) - 2 ' Convert Start Date to Line Number
If StartDateLine1 >= "10" Then
Cells(4, "q").Value = ""
Cells(StartDateLine1, "q").Value = STATUS_1
Cells(StartDateLine1, "z").Value = "START DATE " + START_DATE_1
RowHideNum = StartDateLine1 - 2
Set RowsToHide = Range(Cells(3, "a"), Cells(RowHideNum, "ab"))
RowsToHide.Select
RowsToHide.EntireRow.Hidden = True
End If
Related
I want to write some VBA code that will count how many sets of "contiguous rows of Ts" there are in a single column in a worksheet. However I want such data sets to only be counted if there are more than 500 rows after the final T in a set that contain F values. For example, if T values are found at rows 500-510, then rows 511- 1010 would have to contain F values for one to be added to the count. If another T is encountered before reaching 1010, then the code would "reset" the 500 row counter and begin again.
row 1 - 1000 = F
row 1001 - 1011 = T
row 1012 - 1600 = F
row 1601 - 1611 = T
row 1612 - 3000 = F
In this case the counter would display 2
Conversely:
row 1 - 1000 = F
row 1001 - 1011 = T
row 1012 - 1400 = F
row 1401 - 1411 = T
row 1412 - 3000 = F
The counter would only display 1 as the Ts in cluster 1001-1011 are <500 rows within cluster 1401-1411.
I am also aware that in some scenarios there may be a set of Ts that are within 500 rows of the end of overall data. These would also need to be ignored from the count (I.e. using the example above, if Ts occurred a 2,700 - 2710, in a set of data with 3,000 rows, these would need to be ignored from the count). Similarly I would need to exclude rows 1-500 from the count also.
I don't know if this would be possible or even how to begin writing the code for this, so any assistance will be greatly appreciated. Excerpt of data:
F
F
F
F
F
F
F
F
F
T
T
T
T
T
F
F
F
F
F
F
F
F
This is going to be added to a much larger macro which then goes to filter out all rows containing Ts and deleting them. However I want to perform the count of contiguous Ts first before taking this step.
Code for rest of macro (This code is called by another macro which takes the values generated and pastes them into a master file):
Sub RollMap_Ensocoat(Wb As Workbook)
Dim ws As Worksheet
Dim Rng As Range, Cell As Range
Dim finalRow As Long
'Set name of first sheet in spreadsheet to "1"
With Wb.Sheets(1)
.Name = "1"
End With
'Code to delete all rows that contain a "T" in column G" (Indicating a tab was fired and thus is waste)
With Sheets("1")
finalRow = .Range("G" & Rows.Count).End(xlUp).Row
.AutoFilterMode = False
With .Range("G4:G" & finalRow)
.AutoFilter Field:=1, Criteria1:="T"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
'Code to calculate all the important values of each reel that will be pasted into the master report.
End With
Set ws = Wb.Sheets.Add(After:=Sheets(Wb.Sheets.Count))
With ws
.Range("A3").FormulaR1C1 = "=MAX('1'!C)"
.Range("B3").Formula = "=A3*I3"
.Range("C3").Formula = "=SUBTOTAL(109,'1'!B4:B10000)"
.Range("D3").Formula = "=SUBTOTAL(109,'1'!C4:C10000)"
.Range("E3").Formula = "=SUBTOTAL(109,'1'!D4:D10000)"
.Range("F3").Formula = "=SUBTOTAL(109,'1'!E4:E10000)"
.Range("G3").Formula = "=SUBTOTAL(109,'1'!F4:F10000)"
.Range("H3").Formula = "=SUM(C3:G3)"
.Range("I3").Formula = "='1'!A1"
.Range("J3").Formula = "=H3/(A3*I3)"
.Range("K3").Value = "0.21"
.Range("L3").Value = Wb.Name
.Range("M3").Formula = "=Left(L3, Len(L3) - 4)"
.Range("M3").Copy
.Range("M3").PasteSpecial xlPasteValues
.Range("N3").Formula = "=RIGHT(M3, 11)"
.Range("O3").Formula = "=LEFT(N3,2) & ""/"" & MID(N3,3,2) & ""/20"" & MID(N3,5,2)"
.Range("P3").Formula = "=MID(N3,8,2)& "":"" & MID(N3,10,2)"
.Range("Q3").Formula = "=Left(L3, Len(L3) - 16)"
.Range("A3:Q3").Copy
.Range("A3:Q3").PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("A3:Q3").Copy
End With
End Sub
Code with Tim's suggested additions:
Sub Populate_Ensocoat()
On Error GoTo eh
Dim MyBook As String
Dim Wb As Workbook
Dim strFolder As String
Dim strFil As String
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim xCount As Long
Dim SourceRang1 As Range
Dim FillRange1 As Range
'Code to improve performance
Application.ScreenUpdating = False
Application.EnableEvents = False
'Code to Prompt user to select file location
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
strFolder = .SelectedItems(1)
Err.Clear
End With
'Code to count how many files are in folder and ask user if they wish to continue based on value counted
strFil = Dir(strFolder & "\*.csv*")
Do While strFil <> ""
xCount = xCount + 1
strFil = Dir()
Loop
If MsgBox("You have selected " & xCount & " files. Are you sure you wish to continue?", vbYesNo) = vbNo Then GoTo eh
'Code to Start timer
StartTime = Timer
'Code to make final report sheet visible and launch sheet hidden
Sheet1.Visible = True
Sheet1.Activate
Sheets("Sheet3").Visible = False
'declaring existing open workbook's name
MyBook = ActiveWorkbook.Name
'Code to cycle through all files in folder and paste values into master report
strFil = Dir(strFolder & "\*.csv*")
Do While strFil <> vbNullString
Set Wb = Workbooks.Open(strFolder & "\" & strFil)
Call RollMap_Ensocoat(Wb)
Workbooks(MyBook).Activate
ActiveSheet.Paste
Selection.HorizontalAlignment = xlCenter
ActiveCell.Offset(1).Select
Wb.Close SaveChanges:=False
strFil = Dir
Loop
'Formatting of values in final report
Range("B:I").NumberFormat = "#,##0"
Range("J:K").NumberFormat = "0.000"
Range("L:L").NumberFormat = "0.00"
Range("P:P").NumberFormat = "dd/MM/yyyy"
Range("Q:Q").NumberFormat = "hh:mm"
'Code to add header data to report (i.e. total files, name of person who created report, date and time report was created)
Range("Y2").Value = Now
Range("H2").Value = "# of Files Reported on: " & xCount
Range("P2").Value = Application.UserName
'Re-enabling features disabled for improved macro performance that are now needed to display finished report
Application.EnableEvents = True
Application.ScreenUpdating = True
'Code to refresh sheet so that graphs display properly
ThisWorkbook.RefreshAll
'Code to automatically save report in folder where files are located. Overrides warning prompting user that file is being saved in Non-macro enabled workbook.
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=strFolder & "\" & "Summary Report", FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
'Code to display message box letting user know the number of files reported on and the time taken.
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "Operation successfully performed on " & xCount & " files in " & SecondsElapsed & " seconds." & vbNewLine & vbNewLine & "Report created at location: " & Application.ActiveWorkbook.FullName, vbInformation
Done:
Exit Sub
eh:
MsgBox "No Folder Selected. Please select re-select a board grade"
End Sub
Sub RollMap_Ensocoat(Wb As Workbook)
Dim ws As Worksheet
Dim finalRow As Long
'Set name of first sheet in spreadsheet to "1"
With Wb.Sheets(1)
.Name = "1"
.Range("H1").Formula = "=TCount(G3:G10000)"
End With
'Code to delete all rows that contain a "T" in column G" (Indicating a tab was fired and thus is waste)
With Sheets("1")
finalRow = .Range("G" & Rows.Count).End(xlUp).Row
.AutoFilterMode = False
With .Range("G4:G" & finalRow)
.AutoFilter Field:=1, Criteria1:="T"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
'Code to calculate all the important values of each reel that will be pasted into the master report.
End With
Set ws = Wb.Sheets.Add(After:=Sheets(Wb.Sheets.Count))
With ws
.Range("A3").FormulaR1C1 = "=MAX('1'!C)"
.Range("B3").Formula = "=A3*I3"
.Range("C3").Formula = "=SUBTOTAL(109,'1'!B4:B10000)"
.Range("D3").Formula = "=SUBTOTAL(109,'1'!C4:C10000)"
.Range("E3").Formula = "=SUBTOTAL(109,'1'!D4:D10000)"
.Range("F3").Formula = "=SUBTOTAL(109,'1'!E4:E10000)"
.Range("G3").Formula = "=SUBTOTAL(109,'1'!F4:F10000)"
.Range("H3").Formula = "=SUM(C3:G3)"
.Range("I3").Formula = "='1'!A1"
.Range("J3").Formula = "=H3/(A3*I3)"
.Range("K3").Value = "0.21"
.Range("L3").Value = Wb.Name
.Range("M3").Formula = "=Left(L3, Len(L3) - 4)"
.Range("M3").Copy
.Range("M3").PasteSpecial xlPasteValues
.Range("N3").Formula = "=RIGHT(M3, 11)"
.Range("O3").Formula = "=LEFT(N3,2) & ""/"" & MID(N3,3,2) & ""/20"" & MID(N3,5,2)"
.Range("P3").Formula = "=MID(N3,8,2)& "":"" & MID(N3,10,2)"
.Range("Q3").Formula = "=Left(L3, Len(L3) - 16)"
.Range("R3").Formula = "='1'!H1"
.Range("A3:R3").Copy
.Range("A3:R3").PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("A3:R3").Copy
End With
End Sub
Function TCount(rng As Range)
Const GAP_SIZE As Long = 5 '<< low number for testing...
Dim rv As Long, i As Long, fCount As Long, n As Long, d
Dim haveT As Boolean
rv = 0
d = rng.Value
n = UBound(d, 1)
fCount = 0
If n > GAP_SIZE Then
For i = 1 To n
If d(i, 1) = "T" Then
fCount = 0
haveT = True
Else
fCount = fCount + 1
If fCount = GAP_SIZE And haveT Then
rv = rv + 1
haveT = False
End If
End If
Next i
End If
TCount = rv
End Function
Something like this.
You may need to adjust if I made wrong assumptions about your rules.
Function TCount(rng As Range)
Const GAP_SIZE As Long = 5 '<< low number for testing...
Dim rv As Long, i As Long, fCount As Long, n As Long, d
Dim haveT As Boolean, earlyT as Boolean
rv = 0
d = rng.Value
n = UBound(d, 1)
fCount = 0
If n > GAP_SIZE Then
For i = 1 To n
If d(i, 1) = "T" Then
fCount = 0
If i <= GAP_SIZE Then earlyT = True '<<EDIT
haveT = True
Else
fCount = fCount + 1
If fCount = GAP_SIZE And haveT Then
rv = rv + 1
haveT = False
End If
End If
Next i
End If
TCount = rv - IIf(earlyT, 1, 0) '<< EDIT
End Function
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 6 years ago.
Improve this question
I need to create a csv file from data set matrix, in which I have materials as a rows, people as a columns and quantity of products on intersection. Here is an example of this data set (Order id #1000):
Materials Person1 Person2
563718 20 40
837563 15 35
As a first action I have to transform this data set to a linear structure in this way on additional sheet:
Orderid Material Person Qty
1000 563718 Person1 20
1000 837563 Person1 15
1000 563718 Person2 40
1000 837563 Person2 35
And from this linear structure I have to generate a csv file with Orders for another system based on unique Persons from the list above. Each Order should have one header line and details based on the number of materials he/she ordered. General structure is the following:
H,1000-1,OUT,20160830,Person1
l,1000-1,1,563718,20,EA
l,1000-1,2,837563,15,EA
H,1000-2,OUT,20160830,Person2
l,1000-2,1,563718,40,EA
l,1000-2,2,837563,15,EA
where "H" - means Header row, "1000-1" - first Sub-Order of a Global order 1000, "20160830" requested delivery date, "l" - line row, "1" - line number, "EA" - unit of measure.
Here's a macro that will get you most of the way. It takes the data in your first table and organizes it so that your date in like columns (person1 and person2) is separated into separate rows:
This script assumes that your fixed column(s) are on the left and the columns to be combined (and split out into multiple rows) follow on the right. I hope this helps!
Option Explicit
Sub MatrixConverter2_3()
' Macro created 11/16/2005 by Peter T Oboyski (updated 8/24/2006)
'
' *** Substantial changes made by Chris Brackett (updated 8/3/2016) ***
'
' You are welcome to redistribute this macro, but if you make substantial
' changes to it, please indicate so in this section along with your name.
' This Macro converts matrix-type spreadsheets (eg. plot x species data) into column data
' The new (converted) spreadsheet name is "DB of 'name of active spreadsheet'"
' The conversion allows for multiple header rows and columns.
'--------------------------------------------------
' This section declares variables for use in the script
Dim book, head, cels, mtrx, dbase, v, UserReady, columnsToCombine, RowName, DefaultRowName, DefaultColName1, DefaultColName2, ColName As String
Dim defaultHeaderRows, defaultHeaderColumns, c, r, selectionCols, ro, col, newro, newcol, rotot, coltot, all, rowz, colz, tot As Long
Dim headers(100) As Variant
Dim dun As Boolean
'--------------------------------------------------
' This section sets the script defaults
defaultHeaderRows = 1
defaultHeaderColumns = 2
DefaultRowName = "Activity"
'--------------------------------------------------
' This section asks about data types, row headers, and column headers
UserReady = MsgBox("Have you selected the entire data set (not the column headers) to be converted?", vbYesNoCancel)
If UserReady = vbNo Or UserReady = vbCancel Then GoTo EndMatrixMacro
all = MsgBox("Exclude zeros and empty cells?", vbYesNoCancel)
If all = vbCancel Then GoTo EndMatrixMacro
' UN-COMMENT THIS SECTION TO ALLOW FOR MULTIPLE HEADER ROWS
rowz = 1
' rowz = InputBox("How many HEADER ROWS?" & vbNewLine & vbNewLine & "(Usually 1)", "Header Rows & Columns", defaultHeaderRows)
' If rowz = vbNullString Then GoTo EndMatrixMacro
colz = InputBox("How many HEADER COLUMNS?" & vbNewLine & vbNewLine & "(These are the columns on the left side of your data set to preserve as is.)", "Header Rows & Columns", defaultHeaderColumns)
If colz = vbNullString Then GoTo EndMatrixMacro
'--------------------------------------------------
' This section allows the user to provide field (column) names for the new spreadsheet
selectionCols = Selection.Columns.Count ' get the number of columns in the selection
For r = 1 To selectionCols
headers(r) = Selection.Cells(1, r).Offset(rowOffset:=-1, columnOffset:=0).Value ' save the column headers to use as defaults for user provided names
Next r
colz = colz * 1
columnsToCombine = "'" & Selection.Cells(1, colz + 1).Offset(rowOffset:=-1, columnOffset:=0).Value & "' to '" & Selection.Cells(1, selectionCols).Offset(rowOffset:=-1, columnOffset:=0).Value & "'"
Dim Arr(20) As Variant
newcol = 1
For r = 1 To rowz
If r = 1 Then RowName = DefaultRowName
Arr(newcol) = InputBox("Field name for the fields/columns to be combined" & vbNewLine & vbNewLine & columnsToCombine, , RowName)
If Arr(newcol) = vbNullString Then GoTo EndMatrixMacro
newcol = newcol + 1
Next
For c = 1 To colz
ColName = headers(c)
Arr(newcol) = InputBox("Field name for column " & c, , ColName)
If Arr(newcol) = vbNullString Then GoTo EndMatrixMacro
newcol = newcol + 1
Next
Arr(newcol) = "Data"
v = newcol
'--------------------------------------------------
' This section creates the new spreadsheet, names it, and color codes the new worksheet tab
mtrx = ActiveSheet.Name
Sheets.Add After:=ActiveSheet
dbase = "DB of " & mtrx
'--------------------------------------------------
' If the proposed worksheet name is longer than 28 characters, truncate it to 29 characters.
If Len(dbase) > 28 Then dbase = Left(dbase, 28)
'--------------------------------------------------
' This section checks if the proposed worksheet name
' already exists and appends adds a sequential number
' to the name
Dim sheetExists As Variant
Dim Sheet As Worksheet
Dim iName As Integer
Dim dbaseOld As String
dbaseOld = dbase ' save the original proposed name of the new worksheet
iName = 0
sheetExists = False
CheckWorksheetNames:
For Each Sheet In Worksheets ' loop through every worksheet in the workbook
If dbase = Sheet.Name Then
sheetExists = True
iName = iName + 1
dbase = Left(dbase, Len(dbase) - 1) & " " & iName
GoTo CheckWorksheetNames
' Exit For
End If
Next Sheet
'--------------------------------------------------
' This section notify the user if the proposed
' worksheet name is already being used and the new
' worksheet was given an alternate name
If sheetExists = True Then
MsgBox "The worksheet '" & dbaseOld & "' already exists. Renaming to '" & dbase & "'."
End If
'--------------------------------------------------
' This section creates and names a new worksheet
On Error Resume Next 'Ignore errors
If Sheets("" & Range(dbase) & "") Is Nothing Then ' If the worksheet name doesn't exist
ActiveSheet.Name = dbase ' Rename newly created worksheet
Else
MsgBox "Cannot name the worksheet '" & dbase & "'. A worksheet with that name already exists."
GoTo EndMatrixMacro
End If
On Error GoTo 0 ' Resume normal error handling
Sheets(dbase).Tab.ColorIndex = 41 ' color the worksheet tab
'--------------------------------------------------
' This section turns off screen and calculation updates so that the script
' can run faster. Updates are turned back on at the end of the script.
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'--------------------------------------------------
'This section determines how many rows and columns the matrix has
dun = False
rotot = rowz + 1
Do
If (Sheets(mtrx).Cells(rotot, 1) > 0) Then
rotot = rotot + 1
Else
dun = True
End If
Loop Until dun
rotot = rotot - 1
dun = False
coltot = colz + 1
Do
If (Sheets(mtrx).Cells(1, coltot) > 0) Then
coltot = coltot + 1
Else
dun = True
End If
Loop Until dun
coltot = coltot - 1
'--------------------------------------------------
'This section writes the new field names to the new spreadsheet
For newcol = 1 To v
Sheets(dbase).Cells(1, newcol) = Arr(newcol)
Next
'--------------------------------------------------
'This section actually does the conversion
tot = 0
newro = 2
For col = (colz + 1) To coltot
For ro = (rowz + 1) To rotot 'the next line determines if data are nonzero
If ((Sheets(mtrx).Cells(ro, col) <> 0) Or (all <> 6)) Then 'DCB modified ">0" to be "<>0" to exclude blank and zero cells
tot = tot + 1
newcol = 1
For r = 1 To rowz 'the next line copies the row headers
Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(r, col)
newcol = newcol + 1
Next
For c = 1 To colz 'the next line copies the column headers
Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, c)
newcol = newcol + 1
Next 'the next line copies the data
Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, col)
newro = newro + 1
End If
Next
Next
'--------------------------------------------------
'This section displays a message box with information about the conversion
book = "Original matrix = " & ActiveWorkbook.Name & ": " & mtrx & Chr(10)
head = "Matrix with " & rowz & " row headers and " & colz & " column headers" & Chr(10)
cels = tot & " cells of " & ((rotot - rowz) * (coltot - colz)) & " with data"
'--------------------------------------------------
' This section turns screen and calculation updates back ON.
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox (book & head & cels)
'--------------------------------------------------
' This is an end point for the macro
EndMatrixMacro:
End Sub
Thanks #ChrisB for your answer. Actually I decided to do it my own way and here are the main steps I did:
I created an Excel file with several buttons to which I assigned below Subroutines. Also I have added some parameters, which user can modify (OrderId, Delivery Date and WH id).
I created a Subroutine ReadData(), which clears the Sheet "DATA" in original file and after reads column by column in the data file and generates a linear data set with all required fields on "DATA" Sheet.
After that I simply writes "DATA" sheet to external csv file.
the final code looks like this:
Global Const DAODBEngine = "DAO.DBEngine.36"
Global intColBeg As Integer 'Column Index with Data set to analyze
Global intRowBeg As Integer 'Row Index with Data set to analyze
Sub FileOpen()
Dim filePath As String
filePath = Application.GetOpenFilename()
If filePath = "False" Then Exit Sub
ThisWorkbook.Sheets("BASE").Cells(4, 3) = filePath
End Sub
Sub ClearData()
' Check if DATA Sheet exists
If Evaluate("ISREF('" & "DATA" & "'!A1)") Then
Application.DisplayAlerts = False
ThisWorkbook.Sheets("DATA").Delete
Application.DisplayAlerts = True
End If
Dim sheet As Worksheet
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = "DATA"
End Sub
' This function reads data and adds it to DATA Sheet
Sub ReadData()
Dim i As Integer, l As Integer
Dim intColumn As Integer, intRow As Integer
Dim intAddRow As Integer
Dim wbCopyFrom As Workbook
Dim wbCopyTo As Workbook
Dim wsCopyFrom As Worksheet
Dim wsCopyTo As Worksheet
Dim dataLoc As String, wbLoc As String
Dim mandant As String
Dim orderId As String
Dim orderNum As Integer
Dim shipDate As Date
dataLoc = Trim(ThisWorkbook.Sheets("BASE").Cells(4, 3).Text)
Set wbCopyFrom = Workbooks.Open(dataLoc)
Set wsCopyFrom = wbCopyFrom.Worksheets(1)
ThisWorkbook.Activate
Call ClearData ' Clears all the data on DATA Sheet
Set wbCopyTo = ThisWorkbook
Set wsCopyTo = wbCopyTo.Sheets("DATA")
wbCopyTo.Activate
mandant = wbCopyTo.Sheets("BASE").Cells(11, 3).Text
orderId = wbCopyTo.Sheets("BASE").Cells(7, 3).Text
shipDate = wbCopyTo.Sheets("BASE").Cells(9, 3).Text
' Initial upper left row/column where matrix data begins
intColBeg = 4
intRowBeg = 4
intColumn = intColBeg
intRow = intRowBeg
intAddRow = 1 ' We will add data from this row
orderNum = 1
While Trim(wsCopyFrom.Cells(intRowBeg - 1, intColumn).Text) <> ""
' Header of an Order
wsCopyTo.Cells(intAddRow, 1) = "H;OUT;" & mandant & ";" & orderId & "/" & orderNum & ";" & _
";;" & Mid(shipDate, 7, 4) & Mid(shipDate, 4, 2) & Mid(shipDate, 1, 2) & ";" & _
Trim(wsCopyFrom.Cells(3, intColumn).Text) & ";" & Trim(wsCopyFrom.Cells(2, intColumn).Text) & _
";;;;;;;999;;"
Dim r As Integer
r = 1
intAddRow = intAddRow + 1
While Trim(wsCopyFrom.Cells(intRow, intColBeg - 1).Text) <> ""
If (Trim(wsCopyFrom.Cells(intRow, intColumn).Text) <> "") Then
If Round(CDbl(Trim(wsCopyFrom.Cells(intRow, intColumn).Value)), 0) > 0 Then
' Rows of an Order
wsCopyTo.Cells(intAddRow, 1) = "I;" & orderId & "/" & orderNum & ";" & r & ";" & _
Trim(wsCopyFrom.Cells(intRow, 1).Text) & ";" & Trim(wsCopyFrom.Cells(intRow, intColumn).Value) & _
";PCE;;;;;;;;;;;;;;;"
r = r + 1
intAddRow = intAddRow + 1
End If
End If
intRow = intRow + 1
Wend
intRow = intRowBeg
intColumn = intColumn + 1
orderNum = orderNum + 1
Wend
wbCopyFrom.Close
wbCopyTo.Sheets("BASE").Activate
End Sub
Sub Export()
Dim MyPath As String
Dim MyFileName As String
MyFileName = "Orders_" & Sheets("BASE").Cells(7, 3).Text & "_" & Format(Date, "ddmmyyyy")
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
Sheets("DATA").Copy
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = "" '<~~ The start folder path for the file picker.
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"
End With
NextCode:
If MyPath <> "" Then
Application.DisplayAlerts = False
With ActiveWorkbook
.SaveAs fileName:=MyPath & MyFileName, AccessMode:=xlExclusive, FileFormat:=xlCSV, CreateBackup:=False, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
.Close False
End With
Application.DisplayAlerts = True
Else
On Error Resume Next
ActiveWorkbook.Close SaveChanges:=False
If Err.Number = 1004 Then
On Error GoTo 0
End If
End If
End Sub
I believe that this code isn't optimal as I don't have any experience in VBA and it was a method of trying/changing/trying again in debugging mode and googling in case of issues.
If you can provide any suggestion how to optimise it - that would be great!
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)
I currently have a macro which goes through a column on my master spreadsheet, then exports all the rows where the value input at the start matches the value in the column. It then saves the new worksheet as the value. Here is the code I currently have:
Option Explicit
Public Const l_HeaderRow As Long = 2 'The header row of the data sheet
Public Const l_DistanceCol As Long = 5 'The column containing the distance values
Public Sub ExportDistance()
Dim ws_Data As Worksheet, wb_Export As Workbook, ws_Export As Worksheet
Dim l_InputRow As Long, l_OutputRow As Long
Dim l_LastCol As Long
Dim l_NumberOfMatches As Long
Dim s_Distance As String, l_Distance As Long
Dim s_ExportPath As String, s_ExportFile As String, s_PathDelimiter As String
Set ws_Data = ActiveSheet
s_Distance = InputBox("Enter Distance to Export to New File", "Enter Distance")
If s_Distance = "" Then Exit Sub
l_Distance = CLng(s_Distance)
l_NumberOfMatches = WorksheetFunction.Match(l_Distance, ws_Data.Columns(5), 0)
If l_NumberOfMatches <= 0 Then Exit Sub
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
On Error Resume Next
Call Application.Workbooks.Add
Set wb_Export = Application.Workbooks(Application.Workbooks.Count)
Set ws_Export = wb_Export.Worksheets(1)
Call wb_Export.Worksheets("Sheet2").Delete
Call wb_Export.Worksheets("Sheet3").Delete
Application.DisplayAlerts = True
ws_Export.Name = GetNextSheetname(ws_Data.Name & "-" & s_Distance, wb_Export)
Call ws_Data.Rows(1).Resize(l_HeaderRow).Copy
Call ws_Export.Rows(1).Resize(l_HeaderRow).Select
Call ws_Export.Paste
l_OutputRow = l_HeaderRow + 1
l_LastCol = ws_Data.UsedRange.Columns.Count
For l_InputRow = l_HeaderRow + 1 To ws_Data.UsedRange.Rows.Count
If ws_Data.Cells(l_InputRow, l_DistanceCol).Value = l_Distance Then
Call ws_Data.Range(ws_Data.Cells(l_InputRow, 1), ws_Data.Cells(l_InputRow, l_LastCol)).Copy
Call ws_Export.Rows(l_OutputRow).Select
Call ws_Export.Paste
l_OutputRow = l_OutputRow + 1
ElseIf ws_Data.Cells(l_InputRow, l_DistanceCol).Value = l_Distance Then
Call ws_Data.Range(ws_Data.Cells(l_InputRow, 1), ws_Data.Cells(l_InputRow, l_LastCol)).Copy
Call ws_Export.Rows(l_OutputRow).Select
Call ws_Export.Paste
l_OutputRow = l_OutputRow + 1
End If
Next l_InputRow
s_ExportPath = ThisWorkbook.Path
s_PathDelimiter = Application.PathSeparator
If Right(s_ExportPath, 1) <> s_PathDelimiter Then s_ExportPath = s_ExportPath & s_PathDelimiter
s_ExportPath = s_ExportPath & "Output" & s_PathDelimiter
If Dir(s_ExportPath) = Empty Then
Call MkDir(s_ExportPath)
End If
Select Case Application.DefaultSaveFormat
Case xlOpenXMLWorkbook
s_ExportFile = s_Distance & ".xlsx"
Case xlOpenXMLWorkbookMacroEnabled
s_ExportFile = s_Distance & ".xlsm"
Case xlExcel12
s_ExportFile = s_Distance & ".xlsb"
Case xlExcel8
s_ExportFile = s_Distance & ".xls"
Case xlCSV
s_ExportFile = s_Distance & ".csv"
Case Else
s_ExportFile = s_Distance
End Select
Call wb_Export.SaveAs(Filename:=s_ExportPath & s_ExportFile, FileFormat:=Application.DefaultSaveFormat)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Public Function GetNextSheetname(s_Name As String, Optional wb_Book As Workbook) As String
Dim l_FIndex As Long
Dim s_Target As String
If wb_Book Is Nothing Then Set wb_Book = ActiveWorkbook
s_Name = Left(s_Name, 31)
If IsValidSheet(wb_Book, s_Name) Then
l_FIndex = 1
s_Target = Left(s_Name, 27) & " (" & l_FIndex & ")"
Do While IsValidSheet(wb_Book, s_Target)
l_FIndex = l_FIndex + 1
If l_FIndex < 10 Then
s_Target = Left(s_Name, 27) & " (" & l_FIndex & ")"
ElseIf l_FIndex < 100 Then
s_Target = Left(s_Name, 26) & " (" & l_FIndex & ")"
ElseIf l_FIndex < 1000 Then
s_Target = Left(s_Name, 25) & " (" & l_FIndex & ")"
End If
Loop
GetNextSheetname = s_Target
Else
GetNextSheetname = s_Name
End If
End Function
Public Function IsValidSheet(wbSearchBook As Workbook, v_TestIndex As Variant) As Boolean
Dim v_Index As Variant
On Error GoTo ExitLine
v_Index = wbSearchBook.Worksheets(v_TestIndex).Name
IsValidSheet = True
Exit Function
ExitLine:
IsValidSheet = False
End Function
Please will you help me make this loop through a list of values, rather than my having manually to run the macro each time and input the value myself?
Download this example here.
This is a simple example of how to loop through one range and loop through another range to find the values.
It loops through Column D and then loops through column A, when it finds a match it does something, so basically Column D has taken the place of your inputbox.
run the macro
The code
Sub DblLoop()
Dim aLp As Range 'column A
Dim dLp As Range, dRw As Long 'column D
Dim d As Range, a As Range
Set aLp = Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
dRw = Cells(Rows.Count, "D").End(xlUp).Row
Set dLp = Range("D2:D" & dRw)
'start the loop
'loops through column D and finds value
'in column A, and does something with it
For Each d In dLp.Cells 'loops through column D
For Each a In aLp.Cells 'loops through column A
If d = a Then
'When a match, then do something
'this is where your actual code would go
Range("A" & a.Row & ":B" & a.Row).Copy Cells(Rows.Count, "F").End(xlUp).Offset(1)
End If
Next a 'keeps going through column A
Next d 'next item in column D
End Sub
I have five worksheet in all that are using the below code which is stored in a workbook. The first worksheet works perfectly well with the code. The second spreadsheet can check for the first item before returning the error. The subsequent third and fourth worksheet return the error immediately. The fifth worksheet on the other hand return error 400. May I know is my code the source of the problem or it's the checkbox because I copied and paste from the first worksheet.
Sub test5()
Dim MyFile As String
Dim FinalRow As Long
Dim Row As Long
Dim i As Integer
Dim d As Integer
d = 2
i = 0
FinalRow = Cells(Rows.count, "S").End(xlUp).Row
For Row = 3 To FinalRow
If Not IsEmpty(ActiveSheet.Cells(Row, "S")) Then
i = i + 1
d = d + 1
MyFile = ActiveSheet.Cells(Row, "S").Value
If Dir(MyFile) <> "" Then
ActiveSheet.OLEObjects("CheckBox" & i). _
Object.Value = True ' <~~~~~~~~~~~~~~~~ Error occurs here
With ActiveSheet.Cells(d, "F")
.Value = Now
.NumberFormat = "dd/mm/yy"
'If (ActiveSheet.Cells(d, "F") - ActiveSheet.Cells(d, "G") >= 0) Then
' ActiveSheet.Cells(d, "F").Font.Color = vbRed
'End If
If (.Value - .Offset(0, 1).Value) >= 0 Then
.Font.Color = vbRed
Else
.Font.Color = vbBlack
End If
End With
' i = i + 1
'd = d + 1
End If
End If
Next
End Sub
The program terminates after stepping into this line of code:
ActiveSheet.OLEObjects("CheckBox" & i). _ Object.Value = True
OLEObject does not have a member called value. If you are trying to display the OLEObject, use visible instead
ActiveSheet.OLEObjects("CheckBox" & i).Visible = True
See all OLEObject members here :
OLEObject Object Members