How can I populate a combobox from another workbook, assuming that my data are in a worksheet named "affectation" and the data are in the 1st column
My combobox is in a userform, to fill it from the activeworkbook I use this code :
Private Sub CommandButton1_Click()
Dim ws_Liste_affect As Worksheet
Set ws_Liste_affect = ActiveWorkbook.Worksheets("affectation")
Fin_Liste_affect = ws_Liste_affect.Range("A65530").End(xlUp).Row
For i = 2 To Fin_Liste_affect
UserForm1.ComboBox_affect.AddItem ws_Liste_affect.Range("A" & i)
Next
UserForm1.Show
End Sub
I wan to fill it from another workbook.
I (only) suppose that you need to populate a combo box using data from a sheet of another workbook. If my understanding is correct, please try the next code:
Private Sub CommandButton1_Click__()
Dim ws_Liste_affect As Worksheet, Fin_Liste_affect As Long, arr As Variant
Dim wbFullPath As String, wb As Workbook, boolFound As Boolean
wbFullPath = "C:\...\TheOtherWorkbook.xls"
For Each wb In Workbooks
If wb.FullName = wbfullname Then
Set ws_Liste_affect = wb.Worksheets("the other sheet")
boolFound = True: Exit For
End If
Next
If Not boolFound Then
Set wb = Workbooks.Open(vbfullpath)
Set ws_Liste_affect = wb.Worksheets("the other sheet")
End If
Fin_Liste_affect = ws_Liste_affect.Range("A" & Rows.count).End(xlUp).Row
arr = ws_liste.affect.Range("A2:A" & Fin_Liste_affect).Value
UserForm1.ComboBox_affect.List = arr
UserForm1.Show
End Sub
Related
Wondering why I can't do :
For i = 1 To ThisWorkbook.Sheets.Count
If ThisWorkbook.Sheets(i).Name <> "DO NOT SAVE" Then ThisWorkbook.Sheets(i).Select Replace:=False
Next i
Selection.Copy
what would be the best way to save all sheets which does not match DO NOT SAVE name in another wb ?
Try this:
Sub Tester()
Dim ws As Worksheet, arr(), i As Long
ReDim arr(0 To ThisWorkbook.Worksheets.Count - 2)
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "DO NOT SAVE" Then
arr(i) = ws.Name
i = i + 1
End If
Next ws
Worksheets(arr).Copy
End Sub
A Reflection on the Sheets' Visibility
To export a single sheet to a new workbook, the sheet has to be visible.
To export multiple sheets (using an array of sheet names) to a new workbook, at least one of the sheets has to be visible, while very hidden sheets will not get exported (no error though).
In a given workbook, the following procedure will copy all its sheets, except the ones whose names are in a given array (Exceptions), to a new workbook if at least one of the sheets is visible.
Before copying, it will 'convert' the very hidden sheets to hidden and after the copying, it will 'convert' the originals and copies to very hidden.
Option Explicit
Sub ExportSheets( _
ByVal wb As Workbook, _
ByVal Exceptions As Variant)
Dim shCount As Long: shCount = wb.Sheets.Count
Dim SheetNames() As String: ReDim SheetNames(1 To shCount)
Dim sh As Object
Dim coll As Object
Dim Item As Variant
Dim n As Long
Dim VisibleFound As Boolean
Dim VeryHiddenFound As Boolean
For Each sh In wb.Sheets
If IsError(Application.Match(sh.Name, Exceptions, 0)) Then
Select Case sh.Visible
Case xlSheetVisible
If Not VisibleFound Then VisibleFound = True
Case xlSheetHidden ' do nothing
Case xlSheetVeryHidden
If Not VeryHiddenFound Then
Set coll = New Collection
VeryHiddenFound = True
End If
coll.Add sh.Name
End Select
n = n + 1
SheetNames(n) = sh.Name
End If
Next sh
If n = 0 Then
MsgBox "No sheet found.", vbExclamation
Exit Sub
End If
If Not VisibleFound Then
MsgBox "No visible sheet found.", vbExclamation
Exit Sub
End If
If n < shCount Then ReDim Preserve SheetNames(1 To n) ' n - actual count
If VeryHiddenFound Then ' convert to hidden
For Each Item In coll
wb.Sheets(Item).Visible = xlSheetHidden
Next Item
End If
wb.Sheets(SheetNames).Copy ' copy to new workbook
If VeryHiddenFound Then ' revert to very hidden
Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
For Each Item In coll
wb.Sheets(Item).Visible = xlSheetVeryHidden
dwb.Sheets(Item).Visible = xlSheetVeryHidden
Next Item
End If
MsgBox "Sheets exported: " & n, vbInformation
End Sub
Sub ExportSheetsTEST()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
ExportSheets wb, Array("DO NOT SAVE")
End Sub
Alternatively you could use the following snippet:
Sub CopyWorkbook()
Dim i As Integer
For i = 1 To ThisWorkbook.Sheets.Count
If ThisWorkbook.Sheets(i).Name <> "DO NOT SAVE" Then
Dim rng As Range
Windows("SOURCE WORKBOOK").Activate
rng = ThisWorkbook.Sheets(i).Cells
rng.Copy Before:=Workbooks("TARGET WORKBOOK").Sheets(i)
End If
Next i
End Sub
I have put together the code below to hide named worksheets using a Checkbox. The workbook also contains sheets with the generic names like Sheet1, Sheet2, etc and I would like to be able to hide all sheets whose name contains the word "Sheet" from the same Checkbox.
Is this possible?
Thanks
Private Sub CheckBox1_Click()
Application.ScreenUpdating = False
If CheckBox1 = False Then
If ThisWorkbook.Sheets("Summary").Range("B10") <> "" Then Sheets(ActiveSheet.Range("B10").Value).Visible = False
Else:
If ThisWorkbook.Sheets("Summary").Range("B10") <> "" Then Sheets(ActiveSheet.Range("B10").Value).Visible = True
End If
Application.ScreenUpdating = False
End Sub
If you really want hiding sheets, please use the next code. It hides all sheets where their name starts with ""Sheet":
Private Sub CheckBox1_Click()
Dim sh As Worksheet
For Each sh In Worksheets
If left(sh.name, 5) = "Sheet" Then
sh.Visible = xlSheetVeryHidden
End If
Next
End Sub
Hide Worksheet With Pattern
Reminder
At least one of all sheets in a workbook has to be visible.
There is a third 'visibility' parameter xlSheetHidden which is not considered in this solution.
You can hide multiple worksheets in one go by using an array of worksheet names (fast), but you have to loop through the array to unhide each of them (slow).
The Code
Option Explicit
Private Sub CheckBox1_Click()
Const WorksheetPattern As String = "ShEeT*"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsArr As Variant
Application.ScreenUpdating = False
If CheckBox1 Then ' Hide
wsArr = WorksheetNamesToArray(wb, WorksheetPattern)
wb.Worksheets(wsArr).Visible = xlSheetHidden ' also 0 or False
Else ' UnHide
wsArr = WorksheetNamesToArray(wb, WorksheetPattern, xlSheetHidden)
Dim n As Long
For n = 1 To UBound(wsArr)
wb.Worksheets(wsArr(n)).Visible = xlSheetVisible ' also -1 or True
Next n
End If
Application.ScreenUpdating = True
End Sub
Function WorksheetNamesToArray( _
ByVal wb As Workbook, _
ByVal WorksheetPattern As String, _
Optional ByVal isVisible As XlSheetVisibility = xlSheetVisible) _
As Variant
If Not wb Is Nothing Then
Dim wsCount As Long: wsCount = wb.Worksheets.Count
Dim wsArr() As String: ReDim wsArr(1 To wsCount)
Dim ws As Worksheet
Dim n As Long
For Each ws In wb.Worksheets
If UCase(ws.Name) Like UCase(WorksheetPattern) Then
If ws.Visible = isVisible Then
n = n + 1
wsArr(n) = ws.Name
End If
End If
Next ws
ReDim Preserve wsArr(1 To n)
WorksheetNamesToArray = wsArr
End If
End Function
I found a macro that subtracts the values in one cell in a workbook from another cell in a workbook to output the result in a final third workbook. It exists as such
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim lngDiff As Long
On Error GoTo Err
Application.ScreenUpdating = False
Set wb1 = ActiveWorkbook
Set wb2 = Workbooks.Open("C:\FirstDataFile.xlsx")
Set wb3 = Workbooks.Open("C:\SecondDataFile.xlsx")
lngDiff = wb2.Sheets("Sheet1").Range("A1").Value - _
wb3.Sheets("Sheet1").Range("A1").Value
wb1.Sheets("Sheet1").Range("A1").Value = lngDiff
wb3.Close savechanges:=False
wb2.Close savechanges:=False
Application.ScreenUpdating = True
Exit Sub
Err:
MsgBox Err.Description
End Sub
Is there anyway to modify this code that it can do this for multiple lines at once.
For example. get it to subtract wb2.Sheets("Sheet1").Range("A1").Value - _
wb3.Sheets("Sheet1").Range("A1").Value and output that result into wb1.Sheets("Sheet1").Range("A1").Value and then do the same for A2, A3 and so on so forth until about A:120000? I would also like to be able to get this done on multiples sheets on the two books that I am drawing info from. How would this be done?
Thanks!
I suggest to use a loop through a list of worksheet names, and outsource the subtraction to subroutine InAllValuesOfColumnA that loops through all rows of each sheet as shown below. I further recommend to use meaningful variable names instead of numbered variables (which is a bad practice and easily gets mixed up).
Option Explicit
Public Sub ExampleSample()
Dim wbResult As Workbook, wbData As Workbook, wbSubtract As Workbook
Dim lngDiff As Long
On Error GoTo Err
Application.ScreenUpdating = False
Set wbResult = ActiveWorkbook
Set wbData = Workbooks.Open("C:\FirstDataFile.xlsx")
Set wbSubtract = Workbooks.Open("C:\SecondDataFile.xlsx")
Dim WorksheetList() As Variant
WorksheetList = Array("Sheet1", "Sheet2") 'add the worksheet names here
Dim WsName As Variant
For Each WsName In WorksheetList
InAllValuesOfColumnA OfWorksheet:=wbData.Worksheets(WsName), SubtractWorksheet:=wbSubtract.Worksheets(WsName), WriteToWorksheet:=wbResult.Worksheets(WsName)
Next WsName
wbData.Close SaveChanges:=False
wbSubtract.Close SaveChanges:=False
Application.ScreenUpdating = True
Exit Sub
Err:
MsgBox Err.Description
End Sub
Private Sub InAllValuesOfColumnA(ByVal OfWorksheet As Worksheet, ByVal SubtractWorksheet As Worksheet, ByVal WriteToWorksheet As Worksheet)
Dim LastRow As Long
LastRow = OfWorksheet.Cells(OfWorksheet.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 1 To LastRow 'run from first to last row and subtract
WriteToWorksheet.Cells(iRow, "A").Value = CLng(OfWorksheet.Cells(iRow, "A").Value - SubtractWorksheet.Cells(iRow, "A").Value)
Next iRow
End Sub
An even faster way would be to read/write the data into arrays before/after calculation:
Private Sub InAllValuesOfColumnA(ByVal OfWorksheet As Worksheet, ByVal SubtractWorksheet As Worksheet, ByVal WriteToWorksheet As Worksheet)
Dim LastRow As Long
LastRow = OfWorksheet.Cells(OfWorksheet.Rows.Count, "A").End(xlUp).Row
'read all into array
Dim DataColumn() As Variant
DataColumn = OfWorksheet.Range("A1:A" & LastRow).Value
Dim SubtractColumn() As Variant
SubtractColumn = SubtractWorksheet.Range("A1:A" & LastRow).Value
Dim ResultColumn() As Variant
ResultColumn = WriteToWorksheet.Range("A1:A" & LastRow).Value
Dim iRow As Long
For iRow = LBound(ResultColumn) To UBound(ResultColumn) 'run from first to last row and subtract
ResultColumn(iRow) = CLng(DataColumn(iRow) - SubtractColumn(iRow))
Next iRow
WriteToWorksheet.Range("A1:A" & LastRow).Value = ResultColumn
End Sub
completely new to VBA, would appreciate help with the following problem:
Currently using Sub GoFC() in module to hyperlink shapes on a worksheet ("Menu") to other hidden worksheets (shapes and worksheet text match)
I would like to use Sub GoFC() for shapes in more than one sheet, but the code refers only to one sheet by name. In other words I want for the worksheet "Menu" and worksheet "Menu2" to allow all the shapes in them to run the same macro.
I sincerely hope this makes sense.
This is the code in module:
Sub GoFC()
shtName=Sheets("Menu").Shapes(Application.Caller).TextFrame2.TextRange.Text
Sheets(shtName).Visible = True
Application.Goto Sheets(shtName).Range("A1")
End Sub
This is the code in the worksheet "Menu":
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim shtName As String
'shtName = Target.Name
If InStr(1, Target.SubAddress, "'") = 1 Then
Sh = Mid(Target.SubAddress, 2, Len(Target.SubAddress) - 5)
Else
Sh = Left(Target.SubAddress, InStr(1, Target.SubAddress, "!") - 1)
End If
Sheets(Sh).Visible = True
Sheets(Sh).Select
End Sub
Maybe like that
Sub GoFC()
Dim sht As Worksheet
Dim wb As Workbook
Dim shtName As String
Set wb = ActiveWorkbook
Set sht = wb.ActiveSheet
shtName = sht.Shapes(Application.Caller).TextFrame2.TextRange.Text
If Not wsExists(shtName, wb) Then wb.Sheets.Add.Name = shtName
wb.Sheets(shtName).Visible = True
wb.Sheets(shtName).Activate
wb.Sheets(shtName).Range("A1").Select
End Sub
Function wsExists(wsName As String, wb As Workbook) As Boolean
Dim ws
For Each ws In wb.Sheets
wsExists = (wsName = ws.Name): If wsExists Then Exit Function
Next ws
End Function
I am looking for a code to create sheets with the name in column A. I have used this code but it is not fulfulling my requirement. The code is ;
Private Sub CommandButton1_Click()
Dim sheetCount As Integer
Dim sheetName As String
Dim workbookCount As Integer
With ActiveWorkbook
sheetCount = Sheets(1).Range("A2").End(xlDown).Row
For i = 2 To sheetCount Step 1
sheetName = .Sheets(1).Range("A" & i).Value
workbookCount = .Worksheets.Count
.Sheets.Add After:=Sheets(workbookCount)
.Sheets(i).Name = sheetName
'.Sheets(i).Range("A" & i, "F" & i).Value = .Sheets("sample").Range("A" & i, "F" & i).Value
Next
End With
Worksheets(1).Activate
End Sub
Upon running this code in first go, it creates sheets with the text present in column A. But the problem is when i entered new text in that column, it makes previous sheets as well. I am looking for a code which only create the sheets with the new text being entered in the column and donot make sheets which are already made. Kindly help me out on this as i tried too much but didnt find any code.
Thanks
This works for me, and is tested: Note, if you try to use a name like "History" that is reserved you will get an error. I am not aware of all the reserved names.
Private Sub CommandButton1_Click()
Dim lastRow As Long
Dim sheetName As String
Dim workbookCount As Long
Dim ws As Worksheet
Dim match As Boolean
lastRow = Sheets("Sheet1").Range("A2").End(xlDown).Row
For i = 2 To lastRow
match = False
sheetName = Sheets("Sheet1").Cells(i, 1).Text
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = sheetName Then
match = True
End If
Next
If match = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sheetName
End If
Next i
End Sub
Edit: Added Screen Shots
You can try thi function:
Function SheetExists(SheetName As String) As Boolean
Dim Test As Boolean
On Error Resume Next
Test = Sheets(SheetName).Range("A1").Select
If Test Then
SheetExists = True
Else
SheetExists = False
End If
End Function
Using the function this way:
Sub test()
If SheetExists("MySheet") Then
MsgBox "Sheet exists"
Else
MsgBox "Sheet is missing"
End If
End Sub
I usually have these two helper functions in my workbooks / personal workbook
Option Explicit
Function getSheetWithDefault(name As String, Optional wb As Excel.Workbook) As Excel.Worksheet
If wb Is Nothing Then
Set wb = ThisWorkbook
End If
If Not sheetExists(name, wb) Then
wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)).name = name
End If
Set getSheetWithDefault = wb.Sheets(name)
End Function
Function sheetExists(name As String, Optional wb As Excel.Workbook) As Boolean
Dim sheet As Excel.Worksheet
If wb Is Nothing Then
Set wb = ThisWorkbook
End If
sheetExists = False
For Each sheet In wb.Worksheets
If sheet.name = name Then
sheetExists = True
Exit Function
End If
Next sheet
End Function
To create the worksheets you just iterate over the sheet names and use the getSheetwithDefault function
The following code demonstrate this:
sub createSheets()
dim cursor as Range: set cursor = Sheets("Sheet1").Range("A2")
while not isEmpty(cursor)
getSheetWithDefault(name:=cursor.value)
set cursor = cursor.offset(RowOffset:=1)
wend
end