I'm trying to make a UserForm with comboboxes and textboxes. I have two combobox that are working together. In the first one you choose the right sheet and in the second you choose the right column in the selected sheet.
My problem is that even though my code is working, the second combobox doesn't use the moving information from the first one. It always displays the columns from the first sheet whatever my choice. So how do I get the data from the first one to use it in the second one?
Here's my code:
Private Sub UserForm_Initialize()
Dim I As Long
Me.ComboBox1.Clear
For I = 7 To Sheets.Count
Me.ComboBox1.AddItem Sheets(I).Name
Next
Me.ComboBox1.Value = ActiveSheet.Name
Me.ComboBox2.Clear
Dim j As Integer
Dim puits As String
j = 3
Do While Worksheets(ComboBox1.Text).Cells(1, j).Value <> ""
Me.ComboBox2.AddItem Worksheets(Me.ComboBox1.Text).Cells(1, j).Value
j = j + 3
Loop
End Sub```
EDIT
[USF is to automate the change of the selected cell in this screenshort, same tables on different sheets][1]
[1]: https://i.stack.imgur.com/7bbQG.png
You need to use the Combobox_Change-Event. This Example shows what I mean:
Private Sub ComboBox1_Change()
Dim ws As Worksheet
Dim lCol As Long, i As Long
Set ws = ThisWorkbook.Worksheets(UserForm1.ComboBox1.Value)
lCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For i = 1 To lCol
UserForm1.ComboBox2.AddItem ws.Cells(1, i).Value
Next
End Sub
Private Sub UserForm_Initialize()
Me.ComboBox1.Clear
Me.ComboBox2.Clear
Dim ws As Worksheet
Dim i As Long
i = 1
For Each ws In ThisWorkbook.Worksheets
Me.ComboBox1.AddItem ws.Name
i = i + 1
Next ws
End Sub
When I select the Sheet, I change the first Combobox, which triggers the Change-Event. And I then populate the second Combobox according to the selected sheet.
EDIT
You could insert a CommandButton and use code like the following:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim rng As Range
Set ws = ThisWorkbook.Worksheets(UserForm1.ComboBox1.Value)
Set rng = ws.Range(UserForm1.ComboBox2.Value)
rng.Value = "Your Date"
End Sub
I am trying to create a loop
That the A1:AZ1 data should be copied across all sheets and pastespecial just values into new sheet.
Sub CombineData()
Dim I As Long
Dim xRg As Range
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "Count"
For I = 2 To Sheets.Count
Set xRg = Sheet1.Range("A1:AZ1")
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(I).Activate
ActiveSheet.Range("A1:AZ1").Copy
Next
End Sub
FaneDuru Yes you are right and my comment limit has stoped
Try the next way, please. Now, it adds a new sheet and copy in it, on consecutive rows, the content of "A1:AZ1" range (as value) for all existing worksheets. Is this what you need?
Sub CopyRangeFromAllSheets()
Dim sh As Worksheet, ws As Worksheet, arr As Variant, lastEmptyR As Long
Set sh = Sheets.aDD: sh.Name = "Count"
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> sh.Name Then
arr = ws.Range("A1:AZ1").Value
lastEmptyR = sh.Range("A" & Rows.count).End(xlUp).row
sh.Range("A" & lastEmptyR & ":AZ" & lastEmptyR).Value = arr
End If
Next
End Sub
Edited by #Shoaib Ali not being able to post comments:
Yeah its working fine thanks and my comments limit is stopped
I need help and I'm hoping someone here can help me :)
I have a workbook that runs some reports from Avaya CMS. It runs the report and creates a new sheet for each persons name on the MAIN sheet. << This part works wonderfully.
My issue is I cannot figure out how to use that range of names on the MAIN sheet to select only those specific sheets and then copy them to a new workbook.. There's 2 other hidden sheets as well.. Which is why I think using the range of names is easier but I'm open to anything at this point.
Here's an screeshot of what it looks like :
Sorry, I couldn't figure out how to upload the workbook here but the image should, hopefully, be good enough. Thank you for your time and help!
Here's an image with the hidden sheets.
I need it to exclude the first 3 sheets/
And here's the code:
Sub Macro1()
Dim sheetArray() As String
Dim i As Integer
i = 0
For Each c In MainSheet.Range("A2:A20").Cells
ReDim Preserve sheetArray(0 To i)
sheetArray(i) = c.Value
i = i + 1
Next
Sheets(sheetArray).Select
End Sub
Sub move_Sheets()
Dim mSH As Worksheet
Set mSH = ThisWorkbook.Sheets("Main")
Dim shArray() As String
Dim i As Integer
i = mSH.Range("A" & Rows.Count).End(xlUp).Row
ReDim Preserve shArray(0 To i - 2)
For a = 2 To i
shArray(a - 2) = mSH.Range("A" & a).Value
Next a
ThisWorkbook.Sheets(shArray).Move
End Sub
You could try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, sheetIndex As Long
Dim SheetName As String
Dim ws As Worksheet
With ThisWorkbook.Worksheets("Main")
'Last row of column where the names appears
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop the column from row 2 to last row
For i = 2 To LastRow
'Set Sheet name
SheetName = .Range("A" & i).Value
'Check if the sheet with the SheetName exists
If DoesSheetExists(SheetName) Then
'Insert the code to code
sheetIndex = Workbooks("Book2").Sheets.Count
ThisWorkbook.Worksheets(SheetName).Copy After:=Workbooks("Book2").Sheets(sheetIndex)
Else
End If
Next i
End With
End Sub
Function DoesSheetExists(SheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(SheetName)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function
I have data in some cells in column B that look like Id# plus some number e.g 'Id# 85'
All the other cells have names in them FirstName LastName
I need to find the cells that have Id# in them, I am trying the following, but not working
Thanks
Sub test()
Dim ws As Worksheet
Dim i As Long
Set ws = ThisWorkbook.Sheets("Elements")
With ws
For i = 2 To 180
If .Cells(i, "B").Text Like "Id#" & "*" Then Do something
Next i
End With
End Sub
Try this:
Sub test()
Dim ws As Worksheet
Dim i As Long
Set ws = ThisWorkbook.Sheets("Elements")
With ws
For i = 2 To 180
If Left(.Cells(i, "B").Text, 3) = "Id#" Then
.Cells(i, "C").Value = True
End If
Next i
End With
End Sub
My brain is fried and this is easy points for the usual suspects. div is an array holding sheet names. I am looping through sheets in a master book and if one of the master sheets match one of the sheets in the div array, I want to transfer some data from master sheet to a sheet in thisworkbook.
In the event the sheet does not exist in thisworkbook, add one and name it after the master sheet. What's the most efficient way to do this? I feel like nested loops is a bad idea -_- A collection perhaps?
For i = 0 To UBound(div())
For Each s In book.Worksheets
wsName = Left(s.Name, 5)
If div(i) = wsName Then
If wsExists(wsName) Then
Set ws = ThisWorkbook.Worksheets(wsName)
Exit For
'Debug.Print "true " & ws.name
Else
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = Left(s.Name, 5)
'Debug.Print "false " & ws.name
End If
end if
Next
With ws
.Columns(Start).Resize(, 2).Value = s.Columns("A:B").Value
.Columns(Start + label).Resize(, cols).Value = s.Columns(Start + label).Resize(, cols).Value
End With
Next
Do I even need to check if sheet exists? Code stolen from Tim.
Function wsExists(sName As String) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = ThisWorkbook.Sheets(sName)
On Error GoTo 0
wsExists = Not sht Is Nothing
End Function
Edit: I am calling the loop from a separate routine.
Call drop(thisWB, thisRange, ccArr)
where ccArr is
Dim ccArr() As Variant
ccArr = Array("30500", "30510", "30515", "30530", "30600", "30900", "40500")
The routine where above loop resides opens with
Sub drop(book As Workbook, cols As Integer, div As Variant, Optional startCol As Integer)
but I am getting a byref error trying to pass the array ;_;
Your nested loop is superfluous. You can check the sheet name from div directly against the workbook you want to check it against, then add it if needed.
See the code below, which also addresses the concerns in the edits to your OP. I modified the wsExists function to include a set reference to a particular workbook, which I think makes it more dynamic.
'assumes thisWB and thisRange set above
Dim ccArr() As String, sList As String
sList = "30500,30510,30515,30530,30600,30900,40500"
ccArr = Split(sList, ",")
drop thisWB, thisRange, ccArr 'assumes thisWb and thisRange are set already
' rest of code
'==================================================
Sub drop(book As Workbook, cols As Integer, div() As String, Optional startCol as Integer)
For i = 0 To UBound(div())
If wsExists(ThisWorkbook, div(i)) Then
Set ws = ThisWorkbook.Worksheets(div(i))
Exit For
'Debug.Print "true " & ws.name
Else
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = div(i)
End If
'i think you need this here, otherwise, it will only work on the last worksheet in your loop
With ws
Dim s As Worksheet
Set s = book.Sheets(div(i))
.Columns(Start).Resize(, 2).Value = s.Columns("A:B").Value
.Columns(Start + Label).Resize(, cols).Value = s.Columns(Start + Label).Resize(, cols).Value
End With
Next
End Sub
Function wsExists(wb As Workbook, sName As String) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = wb.Sheets(sName)
On Error GoTo 0
wsExists = Not sht Is Nothing
End Function
Related to the re-sizing code:
This statement ws.Columns(1).Resize(, 2) translates to "2 million+ rows from column 1 and 2"
The solution you found works well but it's not dynamic (hard-coded last row)
This is how I'd setup the copy of columns:
Option Explicit
Public Sub copyCols()
Dim ws1 As Worksheet, ws2 As Worksheet, rng1 As Range, rng2 As Range
Dim cols As Long, lr As Long
Dim col1 As Long 'renamed from "Start" (VBA keyword - property)
Dim lbl As Long 'renamed from "label" (VBA keyword - Control object)
Set ws1 = Sheet1 'ws
Set ws2 = Sheet2 'book.Worksheets(wsName & "-F")
col1 = 1
cols = 2
lbl = 1
lr = ws2.Cells(ws2.UsedRange.Row + ws2.UsedRange.Rows.Count, "A").End(xlUp).Row
Set rng1 = ws1.Range(ws1.Cells(1, col1), ws1.Cells(lr, col1 + 1))
Set rng2 = ws2.Range("A1:B" & lr)
rng1.Value2 = rng2.Value2
Set rng1 = ws1.Range(ws1.Cells(1, col1 + lbl), ws1.Cells(lr, col1 + lbl + cols))
Set rng2 = ws2.Range(ws2.Cells(1, col1 + lbl), ws2.Cells(lr, col1 + lbl + cols))
rng1.Value2 = rng2.Value2
End Sub