Thanks a lot. understood now
Posts by Rmrekoj
-
-
Thank you, sir. Would you please elaborate on the code.
-
Dear Team,
Please assist me in resolving the Subscript Out of range in Dynamic Range when Reclaiming Row .
i just store first value and at second getting error.
Code
Display MoreOption Explicit Sub Reco() Dim a, ca(), da(), Nac(), Nad(), Gl(), Dt() As Variant Dim i As Integer Dim c, d As Integer a = Sheet1.Range("A1").CurrentRegion d = 1 c = 1 For i = LBound(a, 1) To UBound(a, 1) If IsNumeric(a(i, 9)) = True And a(i, 9) > 0 Then If IsEmpty(a(i, 4)) = False Then ReDim Preserve ca(c, 4) ca(c, 1) = Abs(a(i, 4)) ca(c, 2) = a(i, 2) ca(c, 3) = a(i, 1) ca(c, 4) = a(i, 9) ElseIf IsEmpty(a(i, 5)) = False Then ReDim Preserve da(d, 4) da(d, 1) = Abs(a(i, 5)) da(d, 2) = a(i, 2) da(d, 3) = a(i, 1) da(d, 4) = a(i, 9) d = 1 + d Else: MsgBox "Error" End If Else: End If Next i End Sub
Thanks
-
Thank you, however this isn't really what I wanted.
Output should be Name-A, Name-B, Name-C, and Name-D, and more work is being done on the code using this to produce numerous excel files with specified requirements.
If you update the shared vba code, I will be overjoyed.
-
Dear Team,
I need your assistance to obtain the unique values with further names; an excel file with the outcome is also attached.
Thanks
Code
Display MoreSub GetUniques() Dim d, e As Object, c As Variant, i As Long, lr As Long Set d = CreateObject("Scripting.Dictionary") Set e = CreateObject("Scripting.Dictionary") lr = Cells(Rows.Count, 1).End(xlUp).row c = Range("A2:B" & lr) For i = 1 To UBound(c, 1) d(c(i, 1)) = 1 e(c(i, 2)) = 1 Next i Range("J2").Resize(d.Count) = Application.Transpose(d.keys) Range("K2").Resize(e.Count) = Application.Transpose(e.keys) End Sub
-
Oh thanks 👍
-
Thank you for your response,,,
However, it does not function.
getting below remark
#VALUE! -
Finally resolved- this is all I wanted.
Thanks for your support
I need some last advice on how to get the red font. If there are no matching records, "Not Found" should appear in red font.ClientMatch = "Not Found"
ClientMatch.Interior.Color = vbRed
-
SUB () has been created to get the data from sharedrive to a local excel file - and then the function executes the most recent/updated value
I have to run SUB() each time for most recent/updated data-
so I want that sub() should connect in that function ( with RS) so that it will directly link to sharedriver rather than local data -
-
Dear Rory,
Sorry about that - could not well describe it
In the next line, I intend to link the data of the recordset so that when I run the function or utilise it, it will execute with the most recent version straight from the server database.Set rs = newADODB.Recordset
With rs ''Getting error here nowInstead of utilising the sub "GetDataFromSource," I'd want to link it in the preceding line.
#attached the file for your ref
Code
Display MoreFunction ClientMatch(x As String, y As String) Const StartRow = 2 Dim EndRow As Long Dim iRow As Long Dim k As Integer Dim m As LongLong Dim WB As Workbook Dim WS As Worksheet Application.ScreenUpdating = False If InStr(1, y, "|") > 0 Or InStr(1, y, "/") > 0 Then k = InStr(1, y, "|") Or InStr(1, y, "/") m = Left(y, k - 1) Else m = y End If With Worksheets("Database") EndRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row For iRow = StartRow To EndRow If Trim(.Range("B" & iRow).Value) = Trim(x) And .Range("F" & iRow).Value = m Then ClientMatch = .Range("A" & iRow).Value Exit Function End If Next iRow End With ClientMatch = "Notfound" End Function
Code
Display MoreSub GetDataFromSource() Dim cn As ADODB.Connection Set cn = New ADODB.Connection Dim rs As ADODB.Recordset cn.ConnectionString = _ "Provider = Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=T:\OUPUT\;" & _ "Extended Properties=""text;HDR=YES;""" cn.Open Set rs = New ADODB.Recordset rs.ActiveConnection = cn rs.Source = "SELECT * FROM [DataBase.CSV]" rs.Open Sheet2.Rows("2:" & Rows.Count).ClearContents Sheet2.Range("A2").CopyFromRecordset rs rs.Close cn.Close Application.CalculateFullRebuild End Sub
-
Mr. Rory,
Thanks for your response.
I had created a database sheet in the same file as "database" which is being used to run the function, and it was working fine, but instead of copying and pasting the data again and again, there is a real database saved on the server that is regularly updated, so I wanted to use that server data directly in the function so that each time will have the updated records.Here is the current backup code that I use to acquire the most recent and fresh data.
Instead, I expected to have a direct access to the server's CSV file for the function.
Code
Display MoreSub GetDataFromSource() Dim cn As ADODB.Connection Set cn = New ADODB.Connection Dim rs As ADODB.Recordset cn.ConnectionString = _ "Provider = Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=T:\OUPUT\;" & _ "Extended Properties=""text;HDR=YES;""" cn.Open Set rs = New ADODB.Recordset rs.ActiveConnection = cn rs.Source = "SELECT * FROM [MainDatabase.CSV]" rs.Open Sheet2.Rows("2:" & Rows.Count).ClearContents Sheet2.Range("A2").CopyFromRecordset rs rs.Close cn.Close Application.CalculateFullRebuild End Sub
Thank you very much.
-
Team , need your help to fix the error @ with rs
-
Code
Display MoreFunction ClientMatch(x As String, y As String) Const StartRow = 2 Dim EndRow As Long Dim iRow As Long Dim k As Integer Dim m As LongLong Dim WB As Workbook Dim WS As Worksheet Dim cn As ADODB.Connection Dim rs As ADODB.Recordset Set cn = New ADODB.Connection cn.ConnectionString = _ "Provider = Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & ThisWorkbook.Path & "\OUPUT\;" & _ "Extended Properties=""text;HDR=YES;""" '"Extended Properties=""text;HDR=YES;FMT=Delimited;Imex=1;ImportMixedTypes=Text;""" Set rs = New ADODB.Recordset rs.ActiveConnection = cn rs.Source = "SELECT * FROM [CLIENT_DATA_OUT.CSV]" If InStr(1, y, "|") > 0 Or InStr(1, y, "/") > 0 Then k = InStr(1, y, "|") Or InStr(1, y, "/") m = Left(y, k - 1) Else m = y End If Set rs = newADODB.Recordset With rs ''Getting error here now EndRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row For iRow = StartRow To EndRow If Trim(.Range("B" & iRow).Value) = Trim(x) And .Range("F" & iRow).Value = m Then ClientMatch = .Range("A" & iRow).Value Exit Function End If Next iRow End With ClientMatch = "Notfound" End Function
-
Any chance to solve this?
-
Dear Team,
I have a database file that has whole data @attached from that data I simply want an output for that I have discovered a match function that is presently functioning with the same activesheet to extract it but I want to utilise it from the saved database
Code
Display MoreFunction EmpMatch(x As String, y As String) Const StartRow = 2 Dim EndRow As Long Dim iRow As Long Dim k As Integer Dim m As LongLong 'rootpath = "\'Share\NewData\Alberts\Database" 'afile = Dir(rootpath & "*.csv") If InStr(1, y, "|") > 0 Or InStr(1, y, "/") > 0 Then k = InStr(1, y, "|") Or InStr(1, y, "/") 'y = Left(y, InStr(1, y, "|") Or InStr(1, y, "/") - 1) m = Left(y, k - 1) Else m = y End If 'Z = InStr(1, Mystring, "|") 'K = Left(x, NWword - 1) 'With Worksheets("Database") With afile.Sheets("EmpDataBase") 'EndRow = .Range("A:G").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row EndRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row For iRow = StartRow To EndRow If Trim(.Range("B" & iRow).Value) = Trim(x) And .Range("F" & iRow).Value = m Then 'If .Range("B" & iRow).Value = x And .Range("F" & iRow).Value = y Then EmpMatch= .Range("A" & iRow).Value Exit Function End If Next iRow End With EmpMatch= "Notfound" End Function
Please assist.
-
Thank you so much Sir, its really work fine with short data.
but getting stuck with 5,00,000 rows around 60+ MB data any other easy way
-
Hello.
Column "H" contain "D" or "DR" entire row should be deleted, in the excel i have shown the output which i need
Thanks
-
Hi,
Actually i want to delete rows which contain have specific (myown) value.
since the data is huge more than 5 lac rows there is for loop taking too much time for that i am sorting first and then from that specific value till end i could delete entire row by selecting it in range ( Range( Find value : Last Row)
here is the attachment for your reference.
-
Hi Team,
Request you to please suggest me how do i get this selection for delete entire row
CodeFirsfindvalue = Application.WorksheetFunction.Match("D*", Range("H2:H" & LastRow), 0) + 1 LastRow = Activesheet.Cells.SpecialCells(xlCellTypeLastCell).Row Activesheet.Range("A & Firsfindvalue:A" & LastRow).Select
Regards,
Rm