lionheart

Try Sub Test() Dim data(), a(), b(), out(), dic As Object, dataCols As Object, i As Long data = Range("F2:S2").Value a = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value Set dic = CreateObject("Scripting.Dictionary") For i = LBound(a, 1) To UBound(a, 1) If Not dic.Exists(a(i, 1)) Then dic.Add a(i, 1), a(i, 2) Else dic(a(i, 1)) = dic(a(i, 1)) + a(i, 2) Next i ReDim b(1 To UBound(data, 2)) Set dataCols = CreateObject("Scripting.Dictionary") For i = LBound(data, 2) To UBound(data, 2) If Not dataCols.Exists(data(1, i)) Then dataCols.Add data(1, i), i b(i) = dic(data(1, i)) Next i ReDim out(1 To 1, 1 To UBound(data, 2)) For i = LBound(data, 2) To UBound(data, 2) out(1, i) = b(dataCols(data(1, i))) Next i Range("F3:S3").Value = out End Sub

Show us the file and the code you used

The second parameter of List property t = t + Val(.List(i, 3) so change 3 to the column number but pay attention the column numbers in listbox is 0 based so the first column = 0 and the second column = 1 and so on

If you need to distribute the number from left to right, put the following formula in C5 =MID($B$5,COLUMN()-2,1) But if you need to distribute the number from right to left, put the following formula in C5 =MID($B$5,LEN($B$5)-(COLUMN()-COLUMN($C$5)),1)

What's the error message Try using one condition only If ShName = "" Then MsgBox "Cell Is Empty", vbExclamation: Exit Sub

One line ShName = Data.Range("C6").Text If ShName = "" Or IsEmpty(ShName) Then MsgBox "Cell Is Empty", vbExclamation: Exit Sub

Still not clear for me

The question is not clear but this is a code that randomize the data Sub Test() Dim a a = GetRandomRows(Range("A1").CurrentRegion) Range("H1").Resize(UBound(a, 1), UBound(a, 2)).Value = a End Sub Function GetRandomRows(ByVal rng As Range) Dim outputArray(), shuffledRows(), allRows(), selectedRows As Object, numRows As Long, numCols As Long, i As Long, j As Long numRows = rng.Rows.Count numCols = rng.Columns.Count ReDim outputArray(1 To numRows, 1 To numCols) Set selectedRows = CreateObject("Scripting.Dictionary") allRows = Application.Transpose(Evaluate("Row(" & rng.Rows(1).Address & ":" & rng.Rows(numRows).Address & ")")) shuffledRows = ShuffleArray(allRows) For i = 1 To numRows If Not selectedRows.Exists(shuffledRows(i)) Then selectedRows.Add shuffledRows(i), True For j = 1 To numCols outputArray(i, j) = rng(shuffledRows(i) - rng.Row + 1, j) Next j End If Next i GetRandomRows = outputArray End Function Function ShuffleArray(ByVal arr) Dim temp, i As Long, j As Long Randomize For i = UBound(arr) To LBound(arr) + 1 Step -1 j = Int((i - LBound(arr) + 1) * Rnd + LBound(arr)) temp = arr(j) arr(j) = arr(i) arr(i) = temp Next i ShuffleArray = arr End Function

I suppose you are looping through cells in a range so in VBE insert new module then type the code like that Sub Test() Dim cel As Range For Each cel In Range("D1:D10").Cells cel.Value = Replace(cel.Value, "/", "-") Next cel End Sub

You can simply use Replace Function Debug.Print Replace(cell.Value,"/","-")

The code is working well on my side I had a look on the attachment and found that you have changed 3 to 9 in that line t = t + Val(.List(i, 3))

Try this code Sub Test() Const FIXEDPERIOD As Long = 240 Dim outputArray(), currentAmount As Long, relatedValue As Long, i As Long ReDim outputArray(2000, 3) currentAmount = 3000 For i = LBound(outputArray) + 1 To UBound(outputArray) + 1 If currentAmount <= 4000 Then relatedValue = 1350 - (currentAmount - 3000) * (1350 - 1206) / 1000 Else relatedValue = 1206 - (currentAmount - 4000) * (1206 - 1073) / 1000 End If outputArray(i - 1, 0) = currentAmount outputArray(i - 1, 1) = FIXEDPERIOD outputArray(i - 1, 2) = relatedValue outputArray(i - 1, 3) = FIXEDPERIOD * relatedValue currentAmount = currentAmount + 1 If currentAmount Mod 1000 = 0 Then relatedValue = outputArray(i - 1, 2) Next i Columns("H:K").ClearContents Range("H2").Resize(, 4).Value = Array("Salary", "Period", "Amount", "Total") Range("H3").Resize(UBound(outputArray, 1) + 1, UBound(outputArray, 2) + 1).Value = outputArray End Sub

Not clear at all Put some of the expected results

Try this code Private Sub ComboBox1_Change() Dim t As Double, i As Long With Me.ListBox1 For i = 0 To .ListCount - 1 If .List(i, 1) = ComboBox1.Value Then t = t + Val(.List(i, 3)) End If Next i End With Me.TextBox10.Value = t End Sub

You have to know the cause of the error. In the procedure [Private Sub CommandButton3_Click()], you have declared a varaible name [Lsrch] Lsrch = RM3.Range("k5").Value But the sheet RM3 in cell K5 is empty and this causes the error. The cell K5 should have a number, so try to put a number in cell K5 in sheet RM3 and there will be no errors

The right procedure is Test not Macro1

The issue you are experiencing could be due to several factors. Here are a few potential causes and solutions Large file size: If your Excel file contains a large amount of data, hiding rows may not significantly reduce the file size. This can make the file slower to open, especially if you're working with an older computer or a slower hard drive. Consider reducing the size of your file by removing unnecessary data or splitting the file into smaller chunks Complex formulas or formatting: If your file contains complex formulas or formatting, this can also slow down the opening and processing of the file. Try simplifying your formulas or reducing the amount of formatting in the file to improve performance Compatibility issues: If you are using an older version of Excel, it may not be compatible with some of the features in your file, such as conditional formatting or newer functions. Try updating to the latest version of Excel to see if this resolves the issue Corrupted file: If the file is corrupted, this can cause freezing or other issues when trying to unhide rows. Try opening a backup copy of the file or using the Excel built-in repair tool to fix any errors Add-ins or macros: If you have any add-ins or macros running in the background, this can also slow down the file opening and processing. Try disabling any unnecessary add-ins or macros to see if this improves performance

Try this code Const numRows As Long = 100 Sub Test() Dim dataArray(), subArrays(), sheetNames() As String, ws As Worksheet, srcSheet As Worksheet, newSheet As Worksheet, dataRange As Range, sheetName As String, lr As Long, i As Long, j As Long, k As Long, cnt As Long, startRow As Long, endRow As Long Application.ScreenUpdating = False For Each ws In ThisWorkbook.Worksheets If Left(ws.Name, 1) = "T" And IsNumeric(Right(ws.Name, Len(ws.Name) - 1)) Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If Next ws Set srcSheet = ThisWorkbook.Worksheets(1) lr = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row Set dataRange = srcSheet.Range("A2:D" & lr) dataArray = dataRange.Value subArrays = SplitArray(dataArray) cnt = 1 ReDim sheetNames(1 To UBound(subArrays)) For i = 1 To UBound(subArrays) Set newSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)) With newSheet .DisplayRightToLeft = True sheetName = "T" & cnt .Name = sheetName sheetNames(i) = sheetName srcSheet.Rows(1).Copy Destination:=.Rows(1) startRow = (i - 1) * numRows + 1 endRow = WorksheetFunction.Min(i * numRows, UBound(subArrays(i))) For j = 1 To UBound(subArrays(i), 1) For k = 1 To UBound(subArrays(i), 2) .Cells(j + 1, k).Value = subArrays(i)(j, k) Next k Next j cnt = cnt + 1 .Range("A1").CurrentRegion.Columns.AutoFit End With Next i Application.ScreenUpdating = True End Sub Public Function SplitArray(ByVal arr) Dim numRecords As Long, numArrays As Long, i As Long, j As Long, ii As Long, startRow As Long, endRow As Long numRecords = UBound(arr, 1) numArrays = WorksheetFunction.Ceiling(numRecords / numRows, 1) ReDim subArrays(1 To numArrays) For i = 1 To numArrays startRow = (i - 1) * numRows + 1 endRow = WorksheetFunction.Min(i * numRows, numRecords) ReDim subArray(1 To endRow - startRow + 1, 1 To UBound(arr, 2)) For j = startRow To endRow For ii = LBound(arr, 2) To UBound(arr, 2) subArray(j - startRow + 1, ii) = arr(j, ii) Next ii Next j subArrays(i) = subArray Next i SplitArray = subArrays End Function

Can you spot the desired results? Do you want to split every 100 rows of data only or what exactly

Try this code (adjust well the template worksheet) Sub Test() Dim wsTemplate As Worksheet, nameList As Range, newName As String, i As Long Application.ScreenUpdating = False Set wsTemplate = ThisWorkbook.Worksheets("Vehicle") Set nameList = Sheets("Data").Range("A2:A11") For i = 1 To nameList.Rows.Count newName = "T_" & nameList.Cells(i, 1).Value If Evaluate("ISREF('" & newName & "'!A1)") Then Application.DisplayAlerts = False ThisWorkbook.Worksheets(newName).Delete Application.DisplayAlerts = True End If wsTemplate.Copy After:=Worksheets(ThisWorkbook.Worksheets.Count) With ActiveSheet .Name = newName .Range("B2").Value = Mid(newName, 3, Len(newName)) End With Next i Application.ScreenUpdating = True MsgBox "Done", 64 End Sub

What kind of data that exceeds 3 million in rows and how will you intend to manipulate them You can use python programming language and use Pandas library. This can be more easily for you.

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