Posts by mamun.ges
-
-
Dear Kjbox,
Hope you are well in health. I need some changes to the below code (Marked blue) that you created for me.
I need a summation of the "Amount" to the last row,
"TRA_Date" will be the today date,
"Register Note" comes from the e2 cell value,
"Narration" comes from the f2 cell value.
"Address" as a fixed text.
Code
Display MoreSub Button2_Click() Dim x, y, Hdrs, wbk As Excel.Workbook, i As Long, ii As Long, sNm As String Const sPath As String = "E:\Upload Folder\" Hdrs = Array("SL", "Invoice", "Name", "Address", "TSL", "TRA_Date", _ "Amount", "Amount in Word", "Register Note", "Narration") sNm = [j2] ' Load all data in Bill sheet into array x x = Sheet22.[b4].CurrentRegion ' Size and load array y with only visible Invoice Numbers ReDim y(1 To 10, 1 To 1) For i = 2 To UBound(x, 1) If Not Sheets("All Data").Rows(i + 3).Hidden Then ii = ii + 1 ReDim Preserve y(1 To 10, 1 To ii) y(1, ii) = ii y(2, ii) = "'" & x(i, 4): y(3, ii) = "'" & x(i, 7): y(4, ii) = "'" & x(i, 8) y(5, ii) = "'" & x(i, 5): y(6, ii) = "'" & x(i, 3): y(7, ii) = "'" & x(i, 6) y(8, ii) = "'" & x(i, 9): y(9, ii) = "'" & x(i, 12): y(10, ii) = "'" & x(i, 10) End If Next ' Create a new workbook with one sheet Set wbk = Workbooks.Add(1) Application.ScreenUpdating = 0 ' Name the new workbook sheet and add the data to it With wbk.Sheets(1) .Name = sNm ' Write contents of arrays Hdrs & y to the new worksheet .Cells(1, 1).Resize(, 10) = Hdrs .Cells(2, 1).Resize(UBound(y, 2), 10) = Application.Transpose(y) ' Set the formatting for the new sheet (-4108 is the enumeration for xlCenter) With .Cells(1).CurrentRegion .VerticalAlignment = -4108 .Columns(1).HorizontalAlignment = -4108 .Columns(2).Resize(, 2).HorizontalAlignment = -4131 .Columns(4).Resize(, 8).HorizontalAlignment = -4108 .Columns(2).Resize.VerticalAlignment = -4108 .Rows(1).HorizontalAlignment = -4108 .Columns(1).ColumnWidth = 10 .Columns(2).ColumnWidth = 9 .Columns(3).ColumnWidth = 22 .Columns(4).ColumnWidth = 10 .Columns(5).ColumnWidth = 10 .Columns(7).ColumnWidth = 10 .Columns(8).ColumnWidth = 60 .Columns(9).ColumnWidth = 15 End With ' Freeze the header Row ActiveWindow.SplitRow = 1 ActiveWindow.FreezePanes = 1 ' Save the new workbook with required name .Parent.SaveAs sPath & sName & "Doc_Marge" & Format(Now, "dd_mm_yyyy hh_nn") & ".xls", 52 End With End Sub
Hope you help me as you help me before.
Thanks and Advance.
-
Hi, All
I mixed up some code for my worksheet but not working. Need expert opinion and help for correction.
Hope someone will rectify my code below
Code
Display MoreSub RMS_Button3_Click() Dim x, y, Hdrs, wbk As Excel.Workbook, i As Long, ii As Long, sNm As String, dNum As Double, d As Double Const sPath As String = "E:\Upload Folder\" Hdrs = Array("CODE", "DATE", "PURPOSE", "SEQ", "LEG_SL", "ACCOUNT_CODE", "DR_CR", "ACC_CODE", "ACNUM", "CURR_CODE", "AMOUNT", "BC_AMOUNT", "PRINCIPAL", "INTEREST", "CHARGE", "PREFIX", "NUM", "INST", "ORIG_RESP", "CONTCODE", "ADVICE", "DATE", "IBR", "CAN_CODE", "LEG", "NARRATION") sNm = [j2] ' Load all data in Bill sheet into array x x = Sheets("Data Sheet").[a2].CurrentRegion.Columns(2) w = Sheets("Data Sheet").[b2].CurrentRegion.Columns(8) ' Redimension array y to suit size of array x ReDim y(1 To UBound(x, 1) - 1, 1 To 26) ' Get the "Number" from cell D1 cTxt = [c1] gTxt = [g1] ' Size and load array y with only visible Invoice Numbers ReDim y(1 To 26, 1 To 1) For i = 2 To UBound(x, 1) If Not Sheets("Data Sheet").Rows(i + 3).Hidden Then ii = ii + 1 ReDim Preserve y(1 To 26, 1 To ii) y(1, ii) = "'008" y(2, ii) = "'" & Date y(3, ii) = "'" & cTxt y(4, ii) = "1" y(5, ii) = ii y(6, ii) = "18" y(7, ii) = "'D" y(8, ii) = "'2161" y(11, ii) = x(i + 2, 6) d = d + y(11, ii) y(19, ii) = "'O" y(20, ii) = "'" & x(i, 4) y(22, ii) = "'" & Date y(23, ii) = "50" y(26, ii) = "'Cost of " & gTxt Else y(1, ii) = "'008" y(2, ii) = "'" & Date y(3, ii) = "'" & cTxt y(4, ii) = "1" y(5, ii) = ii y(6, ii) = "18" y(7, ii) = "'C" y(8, ii) = "'146" y(11, ii) = d y(26, ii) = "'Cost of " & gTxt End If Next ' Create a new workbook with one sheet Set wbk = Workbooks.Add(1) Application.ScreenUpdating = 0 ' Name the new workbook sheet and add the data to it With wbk.Sheets(1) .Name = sNm ' Write contents of arrays Hdrs & y to the new worksheet .Cells(1, 1).Resize(, 26) = Hdrs .Cells(2, 1).Resize(UBound(y, 2), 26) = Application.Transpose(y) ' Set the formatting for the new sheet (-4108 is the enumeration for xlCenter) With .Cells(1).CurrentRegion .Columns(1).Resize.VerticalAlignment = -4108 .Columns(1).HorizontalAlignment = -4108 .Columns(2).HorizontalAlignment = -4108 .Columns(2).Resize.VerticalAlignment = -4108 .Columns(3).HorizontalAlignment = -4108 .Columns(3).Resize.VerticalAlignment = -4108 .Columns(4).HorizontalAlignment = -4108 .Columns(4).Resize.VerticalAlignment = -4108 .Columns(5).HorizontalAlignment = -4108 .Columns(5).Resize.VerticalAlignment = -4108 .Columns(6).HorizontalAlignment = -4108 .Columns(6).Resize.VerticalAlignment = -4108 .Columns(7).HorizontalAlignment = -4108 .Columns(7).Resize.VerticalAlignment = -4108 .Columns(8).HorizontalAlignment = -4108 .Columns(8).Resize.VerticalAlignment = -4108 .Columns(11).HorizontalAlignment = -4108 .Columns(11).Resize.VerticalAlignment = -4108 .Columns(19).HorizontalAlignment = -4108 .Columns(19).Resize.VerticalAlignment = -4108 .Columns(20).HorizontalAlignment = -4108 .Columns(20).Resize.VerticalAlignment = -4108 .Columns(22).HorizontalAlignment = -4108 .Columns(22).Resize.VerticalAlignment = -4108 .Columns(23).HorizontalAlignment = -4108 .Columns(23).Resize.VerticalAlignment = -4108 .Rows(1).HorizontalAlignment = -4108 .Columns(1).ColumnWidth = 10 .Columns(2).ColumnWidth = 11 .Columns(3).ColumnWidth = 10 .Columns(4).ColumnWidth = 10 .Columns(5).ColumnWidth = 8 .Columns(8).ColumnWidth = 12 .Columns(11).ColumnWidth = 12 .Columns(11).NumberFormat = "#,##0.00" .Columns(19).ColumnWidth = 10 .Columns(20).ColumnWidth = 16 .Columns(22).ColumnWidth = 13 .Columns(26).ColumnWidth = 20 End With ' Freeze the header Row ActiveWindow.SplitRow = 1 ActiveWindow.FreezePanes = 1 ' Save the new workbook with required name .Parent.SaveAs sPath & sName & sNm & " Marge" & Format(Now, "dd_mm_yyyy hh_nn") & ".xls", 52 End With End Sub
Thanks in Advance.
-
I Attached a file.
In report, worksheet time will be summed up based on ID from the Downtime Sheet.
Thanks.
-
-
-
Hi,
I searched many forums but did not findanything to fulfill my needs. Hope someone helps me.
I have an excel workbook, & Worksheet name "Bill"
Search value in AL9 to AL1200 ( Some cells are blank), Hyperlink cell will be AC9 to AC1200.
The file extension is .pdf
Now,
Where Filename exists, then this file needs to search through subfolders 2018, 2019, 2020, 2021 of folder "Data" of E drive. (Like E:\Data\2020)
IF file found then AC value converted into a hyperlink. ( The fact is the AC value will be unchanged.)
example: AL9 value searched in drive E:\Data\ and subfolder 2018, 2019, 2020, 2021, If match found then AC9 value T-9 converted as a hyperlink like T-9.
Thanks in advance.
-
-
Hi,
I am using the below code to create the text box based on cell data.
But now I want this text box to automatically size with the text length and width.
Code
Display MoreSub Current_Click() 'Support to text' Const DELIMITER = " " Dim myFile As String Dim rng As Range Dim cellValue As Variant Dim i As Integer Dim j As Integer Dim sngRow As Range Dim vDat As Variant With Worksheets("Panel") Set rng = .Range("R36:S45") End With Dim noCol As Long noCol = rng.Columns.Count Open "E:\Current.txt" For Output As #1 For Each sngRow In rng.Rows vDat = WorksheetFunction.Transpose(WorksheetFunction.Transpose(sngRow)) vDat = Join(vDat, DELIMITER) If Len(vDat) >= noCol Then Print #1, vDat End If Next Close #1 'open text file' Dim fso As Object Dim sfile As String Set fso = CreateObject("shell.application") sfile = "E:\Current.txt" fso.Open (sfile) End Sub
Can It be possible to do it by using VBA?
Thanks in Advance.
-
Hi, Sorry for the above post.
The problem is unsolved.
Getting error.
Run-time error '1004' Insert method of Range class failed
I can't find out the problem. Help needed.
Thanks.
-
-
Hi,
I have been using the below code for comment entry based on cell value.
Code
Display MorePrivate Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Const sRng As String = "N9:N10" ' change as required Dim sOld As String Dim sNew As String Dim sCmt As String Dim iLen As Long Dim bHasComment As Boolean With Target(1) If Intersect(.Cells, Me.Range(sRng)) Is Nothing Then Application.EnableEvents = True Exit Sub End If sNew = .Text sOld = .Text .Value = sNew Application.EnableEvents = True sCmt = "" & Format$(Now, "dd-mm-YYYY") & Chr(30) & " # " & sOld If Target(1).Comment Is Nothing Then .AddComment Else iLen = Len(.Comment.Shape.TextFrame.Characters.Text) End If With .Comment.Shape.TextFrame .AutoSize = True .Characters.Font.Name = "Times New Roman" .Characters.Font.Size = 14 .Characters.Font.ColorIndex = 1 .Characters(Start:=iLen + 1).Insert IIf(iLen, vbLf, "") & sCmt End With End With End Sub
But it takes only 17 characters. If I input more than 17 characters in the cell N9:N10 then It debugs.
Can anyone tell me what to change to overcome this obstacle?
Hope someone helps me.
Thanks in advance.
-
Yes, RoYUK,
Cell comments are fixed to a cell.
But I want the cell comments of E2 to display just the opposite side of the current side which will be the fixed location for E2 comment. (see Image)
From this
That location
Also, remove the Arrow Icon, Like below.
Can it possible? (It's for comments E2 only, Not all the comments in this worksheet.)
Thanks and Best regards.
-
-
Hi, Expert
Need suggestion.
I searched but to get any good answer of it.
Can a Comment be fixed to a specific location of an excel worksheet?
When I hover on that cell the comment pops up to a specific location without no arrow.
It just happens for only one specific comment of a cell, not all comments of the worksheet.
Is it possible?
Thanks.
-
Hi,
I have a datasheet.
Column D9 to below has a date.
I want a command button; when clicked that popup input box, asking for the month & Year Like "0921"(mmyyyy).
Then it filters column D date data based on that enter month and year value.
Can it be possible? Any suggestion?
If then what will be the code for it.
Thanks in advance.
-
-
Hi,
I am stuck in the following code compile in one. If I compile then some code not working. Can anyone help to compile multiple worksheet change codes in one?
The codes are given below.
Code
Display MorePrivate Sub Worksheet_Change(ByVal Target As Range) Dim x, y, i As Long, ii As Long, lRow As Long If Target.Column = 36 And Target.Row > 8 Then With Sheet4 lRow = .Cells(Rows.Count, 36).End(xlUp).Row x = .Range(.Cells(9, 35), .Cells(lRow, 36)) ReDim y(1 To UBound(x, 1), 1 To 2) End With For i = 1 To UBound(x, 1) If x(i, 2) <> "" Then ii = ii + 1: y(ii, 1) = x(i, 1): y(ii, 2) = x(i, 2) End If Next With Sheet24 lRow = .Cells(Rows.Count, 4).End(xlUp).Row + 1 .Cells(lRow, 4).Resize(UBound(y, 1), 2) = y End With End If Dim KeyCells As Range Set KeyCells = Range("search_string") If Not Application.Intersect(KeyCells, Range(Target.Address)) _ Is Nothing Then FastFilter (KeyCells.Value) End If Dim rFnd As Long If Target.Cells.Count > 1 Then Exit Sub Application.EnableEvents = False If Not Intersect(Target, Range("E9:E1220")) Is Nothing Then rFnd = Range("E9:E1220" & Target.Row).Find(What:=Target.Value, LookAt:=xlWhole).Row Range("AG" & Target.Row) = Range("AG" & rFnd) Range("AH" & Target.Row) = Range("AH" & rFnd) End If Application.EnableEvents = True Dim DateStr As String On Error GoTo EndMacro If Application.Intersect(Target, Range("C9:C1220")) Is Nothing Then If Application.Intersect(Target, Range("G9:G1220")) Is Nothing Then If Application.Intersect(Target, Range("K9:K1220", "L9:L1220")) Is Nothing Then If Application.Intersect(Target, Range("O9:O1220", "V9:V1220")) Is Nothing Then If Application.Intersect(Target, Range("AD9:AD1220")) Is Nothing Then If Application.Intersect(Target, Range("AF9:AF1220")) Is Nothing Then Exit Sub End If End If End If End If End If End If If Target.Cells.Count > 1 Then Exit Sub End If If Target.Value = "" Then Exit Sub End If Application.EnableEvents = False With Target If .HasFormula = False Then Select Case Len(.Formula) Case 4 ' e.g., 9298 = 2-Sep-1998 DateStr = Left(.Formula, 1) & "/" & _ Mid(.Formula, 2, 1) & "/" & Right(.Formula, 2) Case 5 ' e.g., 11298 = 12-Jan-1998 NOT 2-Nov-1998 DateStr = Mid(.Formula, 2, 2) & "/" & _ Left(.Formula, 1) & "/" & Right(.Formula, 2) Case 6 ' e.g., 090298 = 2-Sep-1998 DateStr = Mid(.Formula, 3, 2) & "/" & _ Left(.Formula, 2) & "/" & Right(.Formula, 2) Case 7 ' e.g., 1231998 = 23-Jan-1998 NOT 3-Dec-1998 DateStr = Left(.Formula, 1) & "/" & _ Mid(.Formula, 2, 2) & "/" & Right(.Formula, 4) Case 8 ' e.g., 09021998 = 2-Sep-1998 DateStr = Left(.Formula, 2) & "/" & _ Mid(.Formula, 3, 2) & "/" & Right(.Formula, 4) Case Else Err.Raise 0 End Select .Formula = Format(DateValue(DateStr), "dd/mm/yyyy") End If End With Application.EnableEvents = True Exit Sub EndMacro: MsgBox "Enter a valid date." Application.EnableEvents = True End Sub
And Below this code
Code
Display MorePrivate Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False 'If (Target.Row > 3 And Target.Row < 155) Then Cells(Target.Row, "AT") = Now() Const sRng As String = "M9:M1200" ' change as required Dim sOld As String Dim sNew As String Dim sCmt As String Dim iLen As Long Dim bHasComment As Boolean With Target(1) If Intersect(.Cells, Me.Range(sRng)) Is Nothing Then Application.EnableEvents = True Exit Sub End If sNew = .Text sOld = .Text .Value = sNew Application.EnableEvents = True sCmt = "" & Format$(Now, "dd Mmm YYYY") & Chr(10) & "* " & sOld If Target(1).Comment Is Nothing Then .AddComment Else iLen = Len(.Comment.Shape.TextFrame.Characters.Text) End If With .Comment.Shape.TextFrame .AutoSize = True .Characters(Start:=iLen + 1).Insert IIf(iLen, vbLf, "") & sCmt End With End With
Any help will be highly appreciated.
Thanks in advance
-
Hi,
Need help.
The above code creates a hyperlink of cell-matched data from a folder if the pdf file exists.
But if the cell in the excel file is blank then it also creates a random link to the existing pdf file.
How to ignore this.
If the cell is blank no hyperlink.
Only hyperlink of matched data.
Any help apricated .
Thanks
-
Start From Beginning
Data row strat from 9 rows and 8 is header
Suppose current data entry in row 9
When An Entry is done in E9 a note is created in H9 with some preloaded text. There are some other things in another cell in this row o be done. After that when in AB9 row data enter as "Yes" then the notes of H9 will remove.
Hope you understand.
Any suggestion, How to achieve this?
Thanks.