Results 1 to 10 of 294

Thread: Appendix Thread. ( Codes for other Threads, ( Avinash ).)

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #39
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    10,457
    Rep Power
    10
    Macro in support of this Thread and posts.
    This thread ,
    that thread
    http://www.eileenslounge.com/viewtop...272682#p272682
    https://eileenslounge.com/viewtopic....272706#p272706
    ( and probably a dozen more in the next few months.... )

    Code:
    Sub TextFileToExcel_GroundhogDay12b()  '  http://www.eileenslounge.com/viewtopic.php?f=30&t=35100          http://www.eileenslounge.com/viewtopic.php?p=268809#p268809
    Rem 1 Workbooks,  Worksheets info
    Dim Wb As Workbook, Ws As Worksheet
     Set Wb = Workbooks("macro.xlsb")      ' CHANGE TO SUIT
     Set Ws = Wb.Worksheets.Item(2)      ' second worksheet
    ' Set Ws = Wb.Worksheets("Mylastmacro") ' CHANGE TO SUIT
    Dim lr As Long: Let lr = Ws.Range("A" & Ws.Rows.Count & "").End(xlUp).Row       '   http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466      Making Lr dynamic ( using rng.End(XlUp) for a single column. )
    Dim NxtRw As Long
        If lr = 1 And Ws.Range("A1").Value = "" Then
         Let NxtRw = 2      '  If there is no data in the worksheet we want the second row to be the start row
        Else
         Let NxtRw = lr + 1 '  If there is data in the worksheet, we want the data to be posted after the last used row
        End If
    Rem 2 Text file info
    ' 2a) get the text file as a long single string
    Dim FileNum As Long: Let FileNum = FreeFile(1)                                  ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
    Dim PathAndFileName As String, TotalFile As String
     Let PathAndFileName = ThisWorkbook.Path & "\" & "NSEVAR.txt"   ' CHANGE TO SUIT    From vixer zyxw1234  : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629     DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic  NSEVER.txt: https://app.box.com/s/245h7i5nh6an8vw08g8t08fvu30ylih2
    Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
    TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
    Get #FileNum, , TotalFile
    Close #FileNum
    ' 2b) Split into wholes line _ splitting the text file into rows by splitting by vbCr & vbLf ( Note vbCr & vbLf = vbNewLine )
    Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
    Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1    '  +1 is nedeed as the  Split Function  returns indicies 0 1 2 3 4 5   etc...
    ' we can now make an array for all the rows, and we know our columns are A-J = 10 columns
    Dim arrOut() As String: ReDim arrOut(1 To RwCnt, 1 To 10)
    
    Rem 3 An array is built up by _....
    Dim Cnt As Long
        For Cnt = 1 To RwCnt '               _.. considering each row of data
        Dim arrClms() As String
         Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare)  '  ___.. splitting each row into columns by splitting by the comma
        Dim Clm As Long   '
            For Clm = 1 To UBound(arrClms()) + 1
             Let arrOut(Cnt, Clm) = arrClms(Clm - 1)
            Next Clm
        Next Cnt
    
    Rem 4  Finally the array is pasted to the worksheet at the next free row
    ' Let Ws.Range("A" & NxtRw & "").Resize(RwCnt, 10).Value2 = arrOut()
     Let Ws.Range("A" & NxtRw & ":J" & RwCnt + (NxtRw - 1) & "").Value2 = arrOut()
    ' Ws.Columns("A:J").AutoFit
    Rem 5 to remove  http://www.eileenslounge.com/viewtopic.php?p=272606&sid=7e8ad1b708dd49a811498ccac6b1e092#p272606    .....     when i click on any cell that has output   there is an option numbers stored as text, convert to numbers,help on this error,ignore error,edit in formula bar,error checking options(these are the options coming)
     Let Ws.Range("A" & NxtRw & ":J" & RwCnt + (NxtRw - 1) & "").Value2 = Evaluate("=IF(A" & NxtRw & ":J" & RwCnt + (NxtRw - 1) & "="""","""",IF(ISNUMBER(1*A" & NxtRw & ":J" & RwCnt + (NxtRw - 1) & "),1*A" & NxtRw & ":J" & RwCnt + (NxtRw - 1) & ",A" & NxtRw & ":J" & RwCnt + (NxtRw - 1) & "))")
    ' Let Ws.Range("A" & NxtRw & ":J" & RwCnt + (NxtRw - 1) & "").Value2 = Evaluate("=IF(A" & NxtRw & ":J" & RwCnt + (NxtRw - 1) & "="""","""",IF(ISERROR(1*A" & NxtRw & ":J" & RwCnt + (NxtRw - 1) & "),A" & NxtRw & ":J" & RwCnt & ",1*A" & NxtRw & ":J" & RwCnt + (NxtRw - 1) & "))")
    ' Let Ws.Range("B" & NxtRw & ":D" & RwCnt + (NxtRw - 1) & "").Value2 = Evaluate("=IF(B" & NxtRw & ":D" & RwCnt + (NxtRw - 1) & "="""","""",IF(ISERROR(1*B" & NxtRw & ":D" & RwCnt + (NxtRw - 1) & "),B" & NxtRw & ":D" & RwCnt & ",1*B" & NxtRw & ":D" & RwCnt + (NxtRw - 1) & "))")
    
    End Sub
    _.___________________________


    Macro.xlsb : https://app.box.com/s/uwpnuqmnc1uxpl0wpfrbh52iqr1enfcv
    NSEVER.txt : https://app.box.com/s/245h7i5nh6an8vw08g8t08fvu30ylih2
    Last edited by DocAElstein; 08-06-2020 at 04:09 PM.
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    KILL A MODERATOR!!

Similar Threads

  1. Replies: 192
    Last Post: 08-30-2025, 01:34 AM
  2. Tests and Notes for EMail Threads
    By DocAElstein in forum Test Area
    Replies: 29
    Last Post: 11-15-2022, 04:39 PM
  3. Replies: 379
    Last Post: 11-13-2020, 07:44 PM
  4. Appendix Thread. Diet Protokol Coding Adaptions
    By DocAElstein in forum Test Area
    Replies: 6
    Last Post: 09-05-2019, 10:45 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •