Posts by Hyder14

Sub read_text() 
     
    'Set wb = Workbooks.Add 
    workingflnm =  ActiveWorkbook. Name 
    
        i = 1 'First row in Active  Sheet
      Set fd = CreateObject("Scripting.Filesystemobject") 
    pthnm = "C:\Log Files\" 'Please change to your desired folder
    Set fs = fd.GetFolder(pthnm) 
    For Each fl In fs.Files 
        If InStr(1, fl.Name, "Log", vbTextCompare) > 0 Then 
             
            Set Txtobj = CreateObject("Scripting.filesystemobject") 
            Set Txtfl = Txtobj.getfile(fl) 
            Set Txtstrm = Txtfl.openastextstream(1, -2) 
            Do While Txtstrm.atendofstream <> True 
                rdln = Txtstrm.readline 
                If InStr(1, rdln, "PCU Resistance", vbTextCompare) > 1 Then 
                    x1 = InStr(1, rdln, "PCU Resistance", vbTextCompare) 
                    x2 = InStr(1, rdln, "Ohms", vbTextCompare) 
                    Workbooks(workingflnm).Sheets("Impedance").Cells(i, 1) = fl.Name 
                     ' Construction of Ohms String
                    strg = Mid(rdln, x1 + Len("PCU Resistance"), x2 + Len("Ohms") - (x1 + Len("PCU Resistance"))) 'The String picks the character Ohms in the Line as well
                    Workbooks(workingflnm).Sheets("Impedance").Cells(i, 2) = strg 
                    i = i + 1 
                End If 
             Loop 
             
        End If 
    Next 
     
End Sub

Sub read_text()


Set wb = Workbooks.Add
workingflnm = ActiveWorkbook.Name
i = 1   'First row in Active Sheet
Set fd = CreateObject("Scripting.Filesystemobject")
pthnm = "C:\Log Files\"    'Please change to your desired folder
Set fs = fd.GetFolder(pthnm)
For Each fl In fs.Files
If InStr(1, fl.Name, "Log", vbTextCompare) > 0 Then


Set Txtobj = CreateObject("Scripting.filesystemobject")
Set Txtfl = Txtobj.getfile(fl)
Set Txtstrm = Txtfl.openastextstream(1, -2)
Do While Txtstrm.atendofstream <> True
rdln = Txtstrm.readline
    If InStr(1, rdln, "PCU Resistance", vbTextCompare) > 1 Then
    x1 = InStr(1, rdln, "PCU Resistance", vbTextCompare)
    x2 = InStr(1, rdln, "Ohms", vbTextCompare)
    Workbooks(workingflnm).Sheets(1).Cells(i, 1) = fl.Name
    'Construction of Ohms String
    strg = Mid(rdln, x1 + Len("PCU Resistance"), x2 + Len("Ohms") - (x1 + Len("PCU Resistance")))   'The String picks the character Ohms in the Line as well
    Workbooks(workingflnm).Sheets(1).Cells(i, 2) = strg
    i = i + 1
    End If
    Loop


End If
Next


End Sub

Sub test() 
    Dim fso As Object, myDir As String, fn As String, myFile As String, myDate As  Date, maxDate As Date 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    myDir = "C:\temp"        'Change to your desired directory
    fn = Dir(myDir & "\*.csv) 
    Do While fn <> "" 
        myDate = fso.GetFile(myDir & "\" & fn).DateCreated
        If maxDate < myDate Then 
            myFile = fn 
            maxDate = myDate 
        End If 
        fn = Dir() 
     Loop 
     MsgBox myDir & "\" & fn & " : " & maxDate 
End Sub

Sub Macro1()
     
    Const Increment = 200
    Const Cycle = 84         'You may change the number of repetitions of pasting data
    Const Datalastrow = 50   'You may change the last row number of your data
    Counter = 1
    j = 1
    Do While Counter <= Cycle
        Do
             Sheets("Sheet1").Cells(Datalastrow + j, 1) = Sheets("Sheet1").Cells(j, 1) + Increment
            j = j + 1
         Loop Until j = Datalastrow * Counter + 1
        Counter = Counter + 1
    Loop
     
End Sub

Private Sub CommandButton45_Click()
    Dim wbPrint As Workbook
    Application.ScreenUpdating = False
    Set wbPrint = Workbooks.Open("c:\Receipt Form.xls")


    With wbPrint.Sheets("Driver")
For i = 72 To 86
If ThisWorkbook.Sheets("Stats").Cells(i, 4) <> "" Then
         ThisWorkbook.Sheets("Stats").Cells(i, 4).Copy Destination:=.Cells(3, 2)
        .PrintOut
        
End If
Next
wbPrint.Close savechanges:=False
End With        
End Sub

Sub Macro1()


Const increment = 200
Const Cycle = 84
counter = 1
j = 1
Do While counter < Cycle
Do
Sheets("Sheet1").Cells(51 + j, 1) = Sheets("Sheet1").Cells(j, 1)
Sheets("Sheet1").Cells(51 + j, 2) = Sheets("Sheet1").Cells(j, 2) + increment
j = j + 1
Loop Until j = 51 * counter + 1
counter = counter + 1
Loop


End Sub

Sub Jay()
    Dim xadd, xpaste As Range
Start:
    On Error Resume Next




    Set xadd = Application.InputBox("Please select the range to paste the data from Java File", "Paste from Java File", Type:=8)
    If Err.Number <> 0 Then
    MsgBox Err.Description & ", " & Err.Number, vbOKOnly, "Error"
    Exit Sub
    End If
    If Not xadd Is Empty And Err.Number <> 13 Then
   xadd.Select
    ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, _
    DisplayAsIcon:=False
    Else
    GoTo Start
    End If
 
Start2:
Set xpaste = Application.InputBox("Please select the range to paste the transposed data", "Select a cell for pasting transposed data", Type:=8)
 
    'Copy the data and Paste after Transposing in the selected cell
    If Not xpaste Is Nothing Then
    Range(xadd, xadd.Offset(2, 0)).Copy
    xpaste.Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Else
    MsgBox "Please enter a valid range to paste the data", vbOKOnly
    GoTo Start2
    End If
    Range(xadd, xadd.Offset(2, 0)).Select
    Application.CutCopyMode = False
    Selection.ClearContents
End Sub