lionheart

Try this code Private f As Boolean Private Sub ComboBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) PopulateComboBox Me.ComboBox1 End Sub Private Sub UserForm_Initialize() f = False Me.ComboBox1.MatchEntry = fmMatchEntryNone PopulateComboBox Me.ComboBox1 End Sub Sub PopulateComboBox(ByVal cmb As MSForms.ComboBox) Dim arrIn, arrOut(), i As Long, j As Long With Sheets(1) arrIn = .Range("B2:B" & .Cells(Rows.Count, "B").End(xlUp).Row).Value End With ReDim arrOut(1 To UBound(arrIn)) For i = 1 To UBound(arrIn) If arrIn(i, 1) Like "*" & cmb.Text & "*" Then j = j + 1 arrOut(j) = arrIn(i, 1) End If Next i If j = 0 Then cmb.Clear: Exit Sub ReDim Preserve arrOut(1 To j) With cmb .Clear .List = arrOut If j > 0 And f Then .DropDown Else f = True End With End Sub

Not so clear for me Here's the modified code that enables you to add new data without clearing the existing data Sub Get_Data_From_Closed_Workbooks() Dim a, wb As Workbook, ws As Worksheet, sFile As String, sPath As String, lr As Long, m As Long Application.ScreenUpdating = False sPath = ThisWorkbook.Path & "\" sFile = Dir(sPath & "*.xlsx") m = shSales.Cells(Rows.Count, "E").End(xlUp).Row + 1 ' With shSales.Range("B1").CurrentRegion.Offset(1) ' .ClearContents: .Borders.Value = 0 ' End With Do While sFile <> "" Set wb = Workbooks.Open(sPath & sFile, ReadOnly:=True) Set ws = wb.Sheets(2) With ws lr = .Cells(Rows.Count, "E").End(xlUp).Row a = .Range("B2:H" & lr).Value .Parent.Close False End With shSales.Range("B" & m).Resize(UBound(a, 1), UBound(a, 2)).Value = a m = m + UBound(a, 1) sFile = Dir() Loop With shSales.Range("B2:H" & m - 1) .Borders.Value = 1 End With With shSales.Range("D2:D" & m - 1) .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C" .Value = .Value End With Application.ScreenUpdating = True MsgBox "Done", 64 End Sub The point of duplicates is not clear at all As for creating a shortcut icon, you can do that following the quick access bar

Maybe Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range If Not Application.Intersect(Target, Me.Range("B4:B100")) Is Nothing Then For Each cell In Application.Intersect(Target, Me.Range("B4:B100")) If cell.Value = "Yes" And cell.Offset(0, -1) = Empty Then cell.Offset(0, -1).Value = Date ElseIf cell.Value = "No" And cell.Offset(0, -1) <> Empty Then cell.Offset(0, -1).ClearContents End If Next cell End If End Sub

Can you explain in words what the problem is

Please open new topic and give more details

Peace be upon you. You have to be more organized and specific in your explanation to the problem Create a new workbook with `xlsm` extension in the same path of your files and name it `MAIN.xlsm`, then open the workbook Press Alt + F11 to login VBE then insert a new module, put the following code Sub Get_Data_From_Closed_Workbooks() Dim a, wb As Workbook, ws As Worksheet, sFile As String, sPath As String, lr As Long, m As Long Application.ScreenUpdating = False sPath = ThisWorkbook.Path & "\" sFile = Dir(sPath & "*.xlsx") m = 2 With shSales.Range("B1").CurrentRegion.Offset(1) .ClearContents: .Borders.Value = 0 End With Do While sFile <> "" Set wb = Workbooks.Open(sPath & sFile, ReadOnly:=True) Set ws = wb.Sheets(2) With ws lr = .Cells(Rows.Count, "E").End(xlUp).Row a = .Range("B2:H" & lr).Value .Parent.Close False End With shSales.Range("B" & m).Resize(UBound(a, 1), UBound(a, 2)).Value = a m = m + UBound(a, 1) sFile = Dir() Loop With shSales.Range("B2:H" & m - 1) .Borders.Value = 1 End With With shSales.Range("D2:D" & m - 1) .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C" .Value = .Value End With Application.ScreenUpdating = True MsgBox "Done", 64 End Sub I will attach the file just for you. Click on the icon in the quick access bar MAIN.xlsm

This error message typically occurs when the userform you are trying to load relies on an ActiveX control or an external library that is not installed on the machine where you are trying to open the file. To resolve this issue, you can either Install the missing component(s) on the machine where you are trying to open the file * Remove the dependency on the missing component(s) from the userform * You can check which component(s) are missing by opening the userform in the VBA editor and checking the code or the userform's design. You can also check if the component(s) are available in another machine where you have access to Excel and copy it to the machine where the error occurs

Peace be upon you. Put the following code in worksheet module (Sheet2) Right-click on Sheet2 > View Code > Paste the following macro Private Sub Worksheet_Change(ByVal Target As Range) Const sRow As Long = 9, sTargetCell As String = "F10" Dim x, a, ws As Worksheet, sh As Worksheet, lr As Long If Target.Address = "$F$8" Then Set ws = Sheet1: Set sh = Sheet2 With sh.Range(sTargetCell) .Resize(Rows.Count - .Row + 1).ClearContents End With If Target.Value = Empty Then Exit Sub lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < sRow + 1 Then MsgBox "No Data In Sheet1", vbExclamation: Exit Sub x = Application.Match(Target.Value, ws.Rows(sRow), 0) If IsError(x) Then MsgBox "Subject Not Found In Sheet1", vbExclamation: Exit Sub a = ws.Range(ws.Cells(sRow + 1, x), ws.Cells(lr, x)).Value sh.Range(sTargetCell).Resize(UBound(a, 1), UBound(a, 2)).Value = a End If End Sub

Change this line to suit you If Target.Column = 2 Or Target.Column = 4 Or Target.Column = 6 Then

In standard module put the following code #If Win64 Then Private Declare PtrSafe Function GetKeyboardLayout Lib "user32" (ByVal idThread As Long) As Long Private Declare PtrSafe Function Keyboard Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal ss As String, ByVal sss As Long) As LongPtr #Else Private Declare Function GetKeyboardLayout Lib "user32" (ByVal idThread As Long) As Long Private Declare Function Keyboard Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal ss As String, ByVal sss As Long) As Long #End If Public Function GetCurrentKeyboardLayout() As String GetCurrentKeyboardLayout = Hex(GetKeyboardLayout(0)) End Function Public Sub SetEnglish() Call Keyboard("00000409", 1) End Sub Public Sub SetArabic() Call Keyboard("00000401", 1) End Sub Then in worksheet module put the following code Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 2 Then If GetCurrentKeyboardLayout = "00000409" Then Exit Sub Call SetEnglish Else If GetCurrentKeyboardLayout = "00000401" Then Exit Sub Call SetArabic End If End Sub

Please put some files of different cases in a folder then compress the folder and upload it to the topic. Also upload the excel file with some of the expected results if you really need help

Peace be upon you. Try the following UDF in standard module Function ElapsedPercent(ByVal startDate, ByVal endDate, ByVal checkDate) If IsEmpty(startDate) Or IsEmpty(endDate) Or IsEmpty(checkDate) Or Not IsDate(startDate) Or Not IsDate(endDate) Or Not IsDate(checkDate) Then ElapsedPercent = vbNullString: Exit Function End If If checkDate < startDate Then ElapsedPercent = "Not Yet" ElseIf checkDate > endDate Then ElapsedPercent = "100%" Else ElapsedPercent = Format((checkDate - startDate + 1) / (endDate - startDate + 1), "0%") End If End Function Then you can use the UDF as following =ElapsedPercent(D12,E12,B12) Another solution using Formula =IF(OR(ISBLANK(D12), ISBLANK(E12), ISBLANK(B12)), "",IF(B12 < D12, "Not Yet",IF(B12 > E12, "100%",TEXT((B12 - D12 + 1) / (E12 - D12 + 1), "0%"))))

Peace be upon you More details will be more useful indeed Mention the form you are working on [UserForm1] and the worksheet you would like to search in and the column you are dealing will and give some examples of results

Remove all the code in ThisWorbook module before executing the following code. Also make the worksheet you desire to copy to be Active Sub Test() Dim ws As Worksheet, sh As Worksheet, sName As String, cnt As Long Set ws = ActiveSheet cnt = 1 If InStr(ws.Name, "-") Then sName = Left(ws.Name, 3) & Right(Year(Date), 2) Else MsgBox "Worksheet Name Should Have A Hyphen", vbExclamation: Exit Sub End If Do While SheetExists(sName & "-" & cnt) = True cnt = cnt + 1 Loop If cnt > 12 Then MsgBox "The Number of Copies Has Reached Its Limit.", vbExclamation: Exit Sub End If ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) Set sh = ActiveSheet sh.Name = sName & "-" & cnt End Sub Function SheetExists(ByVal sheetName As String) As Boolean Dim ws As Worksheet On Error Resume Next Set ws = ThisWorkbook.Sheets(sheetName) On Error GoTo 0 If ws Is Nothing Then SheetExists = False Else SheetExists = True End Function

That's what my code do exactly. Review the code well

You can change the code to suit your file. You have to do that yourself

I don't know. You can send messages to Microsoft support to ask them for that point A friend of mine shows me it is possible to insert png image but this requires codes with API Windows to change the image and make it transparent before inserting it I didn't get your question. You can post a new question better as this question is different from the current one

Try this code (Add it to the userform module) Private Sub TextBox1_Change() Dim arrExtensions, x, ws As Worksheet, sImagePath As String, sFile As String, i As Long Set ws = ThisWorkbook.Sheets(1) arrExtensions = Array(".jpg", ".jpeg", ".png", ".gif", ".bmp") x = Application.Match(Val(TextBox1.Value), ws.Columns(1), 0) If IsError(x) Then Me.Image1.Picture = Nothing: Exit Sub sFile = ws.Range("A" & x).Value For i = 0 To UBound(arrExtensions) sImagePath = ThisWorkbook.Path & "\" & sFile & arrExtensions(i) If Dir(sImagePath) <> "" Then On Error Resume Next Me.Image1.Picture = LoadPicture(sImagePath) If Err.Number <> 0 Then MsgBox "Error Loading The Image: " & Err.Description On Error GoTo 0 Else Exit For End If End If Next i End Sub But you have to know the png extension is not supported by userform image control so this will raises Invalid Picture

Draw a button inside cell B9 or any other cell that will be visible all the time and assign the following macro to that button. The code is flexible and you can assign the desired columns to be shown and also to assign the rows you would like to hide Sub Test() Dim desiredColumns(), aRows(), e, ws As Worksheet, columnsHidden As Boolean, lastColumn As Long, i As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Sheets(1) With ws desiredColumns = Array(2, 3, 7, 9, 10, 13, 15, 20, 23) aRows = Array("1:8", "25:27") lastColumn = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column If Not columnsHidden Then .Columns(lastColumn + 1).Resize(, .Columns.Count - lastColumn).EntireColumn.Hidden = True For i = 1 To lastColumn If Not IsInArray(i, desiredColumns) Then .Columns(i).EntireColumn.Hidden = True End If Next i For Each e In aRows .Rows(e).EntireRow.Hidden = True Next e columnsHidden = True .PrintPreview .Activate GoTo iLine Else iLine: .Columns.EntireColumn.Hidden = False For Each e In aRows .Rows(e).EntireRow.Hidden = False Next e columnsHidden = False End If End With Application.ScreenUpdating = True End Sub Function IsInArray(ByVal valToBeFound, ByVal arr) As Boolean Dim ele For Each ele In arr If ele = valToBeFound Then IsInArray = True: Exit Function Next ele IsInArray = False End Function

I will not work on that topic till you attach a file. That's waste of time

Try this version Sub Test() Const iFirstRow As Long = 1, iFirstColumn As Long = 1, iLastRow As Long = 20, iLastColumn As Long = 5 Dim wb As Workbook, ws As Worksheet, r As Range Application.ScreenUpdating = False Application.DisplayAlerts = False Set ws = ActiveSheet Set r = ws.Range(ws.Cells(iFirstRow, iFirstColumn), ws.Cells(iLastRow, iLastColumn)) Set wb = Workbooks.Add(xlWBATWorksheet) With wb ws.Copy Before:=.Worksheets(1) .Worksheets(2).Delete With .Worksheets(1) .Range(r.Address).Value = .Range(r.Address).Value .Rows(iLastRow + 1 & ":" & .Rows.Count).Delete .Columns(iLastColumn + 1).Resize(, .Columns.Count - iLastColumn).Delete .Name = ws.Name End With .SaveAs ThisWorkbook.Path & "\Output", 51 .Close 0 End With Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "Done", 64 End Sub Change the first line in the code to suit the range you desire. In my case this range is A1 to E20

Attach sample of your file

Are you sure? Did you try the code well If the code doesn't work well, please attach a file to have a look

Try this code Sub Test() Dim wb As Workbook, ws As Worksheet, sh As Worksheet, r As Range Set ws = ActiveSheet Set r = ws.Range("A1:L50") Set wb = Application.Workbooks.Add With wb Set sh = .Worksheets(1) r.Copy sh.Range("A1") sh.Range(r.Address).Value = sh.Range(r.Address).Value Application.DisplayAlerts = False .SaveAs ThisWorkbook.Path & "\Output", 51 Application.DisplayAlerts = True .Close 0 End With End Sub

Try this code Sub Test() ExportAsPDF "Cards" End Sub Public Sub ExportAsPDF(ByVal sOut As String) Dim ws As Worksheet, s As String For Each ws In ThisWorkbook.Worksheets If InStr(ws.Name, Chr(199) & Chr(225) & Chr(200) & Chr(216) & Chr(199) & Chr(222) & Chr(201)) Then s = s & IIf(s <> Empty, ",", Empty) & ws.Name Next ws PrintToPDF Split(s, ","), ThisWorkbook.Path & "\" & sOut & ".pdf" End Sub Public Sub PrintToPDF(arr, sFileName As String, Optional vQuality = xlQualityStandard, Optional vIncDocProperties = True, Optional vIgnorePrintAreas = False, Optional vOpenAferPublish = False) ThisWorkbook.Sheets(arr).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFileName, Quality:=vQuality, IncludeDocProperties:=vIncDocProperties, IgnorePrintAreas:=vIgnorePrintAreas, OpenAfterPublish:=vOpenAferPublish ActiveSheet.Select End Sub