This program is working fine I just want to append my tag to next row without any limit.
Sub ExportExcel(ByVal Atai)
Dim a
Set a = CreateObject("Excel.Application")
a.Visible = True
a.Workbooks.Open "C:\Users\Muhammad Awais\Desktop\start and stop data logging\POWER METER 1.xls"
**
**a.Sheets("raw data").Cells(3, 4).Value = SmartTags("l1-l2")
a.Sheets("raw data").Cells(4, 4).Value = SmartTags("l2-l3")
****
a.ActiveWorkbook.SaveAs "C:\Users\Muhammad Awais\Desktop\start and stop data logging\"&Day(Date)& ("_") &Month(Date)& ("_") &Year(Date)& ("_") &Hour(Time)&Minute(Time)&".xls"
a.Workbooks.Close
a.Quit
Set a = Nothing
End Sub
LastRow = sh.Cells.Find(What:="*", _
After:=a.Sheets("raw data").Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
I try to read my text file with thousands rows and several columns in it, but VB6 limit me with only 338 rows for the entire program. Can anyone give me solution for that problem?
This is the code I already try (that dat is a text file):
Public TF As Integer, SF As String, NoRs As Integer
Public Type tFile
Number As String
Name As String
NIM As String
Class As String
Room As String
Department As String
Faculty As String
Univ As String
Role As String
End Type
Public myFile(1 To 2650) As tFile '2650 is Number of Rows in my Text File
Public Sub cFile()
TF = FreeFile
SF = App.Path & IIf(Right$(App.Path, 1) = "\", "", "\") & "String\myfile.dat"
Open SF For Input As #TF
NoRs = 0
Do Until EOF(TF)
NoRs = NoRs + 1
With myFile(NoRs)
Input #TF, _
.Number, _
.Name, _
.NIM, _
.Class, _
.Room, _
.Department, _
.Faculty, _
.Univ, _
.Role
End With
Loop
Close #TF
End Sub
It work until Row 338, but if I scroll down pass that row, it will out of range.
In my master workbook I have 1 table in each one of my 4 sheets and in sheet2 and sheet4 I have a couple of columns with IF and VLOOKUP functions at the right of the table.
I am trying to do the following:Clear content from the 4 tables while maintaining only one row of formulas (in sheet 2 and 4), Copy the range I want from a table in sheet1 of another workbook (repeat for other sheets), And paste into the table of sheet1 of master workbook (repeat for other sheets), Autofill the formulas of the remanining columns (only in sheet 2 and 4).
While the code does it's job, it takes almost 2 hours to perform this task! Even the Clearcontent of sheet2 takes 8 minutes for just 250 rows which seems ridiculous long time! Sheet1 has 1000 rows, sheet2 has 250, sheet3 has 1000, sheet4 has 26k rows.
Code seems too big for what it does. What can I do to optimise and speed up the code? Any viable work around or is this normal? I have tried Application.Calculation = xlCalculationManual but no improvement.
Sub LoopThroughDirectory()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim MyFile As String
Dim erow1
Dim erow2
Dim erow3
Dim erow4
Dim Filepath As String
Dim wkb As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim sht3 As Worksheet
Dim sht4 As Worksheet
Dim ero2 As Long
Dim ero4 As Long
Dim lastero1 As Long
Dim lastero2 As Long
Dim lastero3 As Long
Dim lastero4 As Long
Folha1.Activate
Folha1.Range(Cells(3, 1), Cells(99999, 173)).ClearContents
Folha1.Range(Cells(2, 1), Cells(99999, 173)).ClearContents
Folha2.Activate
Folha2.Range(Cells(3, 1), Cells(99999, 150)).ClearContents
Folha2.Range(Cells(2, 1), Cells(99999, 137)).ClearContents
Folha3.Activate
Folha3.Range(Cells(3, 1), Cells(99999, 197)).ClearContents
Folha3.Range(Cells(2, 1), Cells(99999, 197)).ClearContents
Folha4.Activate
Folha4.Range(Cells(3, 1), Cells(99999, 152)).ClearContents
Folha4.Range(Cells(2, 1), Cells(99999, 108)).ClearContents
Filepath = "C:\Users\carlos\Downloads\Projectos\Teste\"
MyFile = Dir(Filepath)
Do While MyFile = "Dados Projectos New"
If MyFile = "Dados Projectos_Master.xlsm" Then
Exit Sub
End If
Set wkb = Workbooks.Open(Filepath & MyFile)
Set sht1 = wkb.Sheets("Encomendas")
Set sht2 = wkb.Sheets("Projectos")
Set sht3 = wkb.Sheets("Casos")
Set sht4 = wkb.Sheets("Actividades Serviço")
wkb.Activate
sht1.Activate
With Sheets("Encomendas") 'Last row of the first sheet I want to copy
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastero1 = .Range("A:fq").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("a2:fq" & lastero1).Copy
Folha1.Activate
'last row of the first sheet of master workbook I want to paste
erow1 = Folha1.Cells.Find("*", After:=Range(Cells(Rows.Count, 173), Cells(Rows.Count, 173)), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Encomendas").Range(Cells(erow1 + 1, 1), Cells(erow1 + 1, 173))
wkb.Activate
sht2.Activate
With Sheets("Projectos") 'Last row of the second sheet I want to copy
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastero2 = .Range("A:EG").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("a2:Eg" & lastero2).Copy
Folha2.Activate
With Sheets("Projectos") 'Last row of the second sheet of master workbook I want to paste
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
erow2 = .Range("A:EG").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Projectos").Range(Cells(erow2 + 1, 1), Cells(erow2 + 1, 137))
With Sheets("Projectos") 'Last row of the second sheet of master workbook I want to autofill
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
ero2 = .Range("A:EG").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("EH2:ET2").AutoFill Destination:=Range("EH2:ET" & ero2)
wkb.Activate
sht3.Activate
With Sheets("Casos") 'Last row of the third sheet I want to copy
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastero3 = .Range("A:go").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("a2:go" & lastero3).Copy
'Last row of the third sheet of master workbook I want to paste
erow3 = Folha3.Cells.Find("*", After:=Range(Cells(Rows.Count, 197), Cells(Rows.Count, 197)), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Folha3.Activate
ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Casos").Range(Cells(erow3 + 1, 1), Cells(erow3 + 1, 197))
wkb.Activate
sht4.Activate
With Sheets("Actividades Serviço") 'Last row of the fourth sheet I want to copy
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastero4 = .Range("A:dd").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("a2:dd" & lastero4).Copy
ActiveWorkbook.Close
Folha4.Activate
With Sheets("Actividades serviço") 'Last row of the fourth sheet of master workbook I want to paste
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
erow4 = .Range("A:DD").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Actividades serviço").Range(Cells(erow4 + 1, 1), Cells(erow4 + 1, 108))
With Sheets("Actividades serviço") 'Last row of the fourth sheet of master workbook I want to autofill
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
ero4 = .Range("A:DD").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("de2:EV2").AutoFill Destination:=Range("de2:Ev" & ero4)
MyFile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Issues I see so far:
Folha1.Activate
Folha1.Range(Cells(3, 1), Cells(99999, 173)).ClearContents
Folha1.Range(Cells(2, 1), Cells(99999, 173)).ClearContents
You don’t need to activate since youre quite literally telling it where to clear contents.
Range("a2:fq" & lastero1).Copy
No need to copy, you can literally saying something like “Range(“a1”).Value = Range(“C2”).Value. This also means by extension that you don’t have to paste as well.
Some of the major performance tips for macros suggest not to “Copy/Paste” as well as try to avoid “selecting” and “activating.” In fact, directly manipulating worksheets is often seen as cardinal sin.
With larger data sets that need to be moved around, storing everything in an array before dumping to new locations also saves big on time.
Hopes this helps.
I have a "users.dbf" table with the "users.cdx" index file it's a free table, so there is no dbc file. Both are located in the same folder. Sometimes when I add a new row in users.dbf, users.cdx is not updated, the link between dbf and cdx is broken. This table belongs to a third party app.
To solve this problem I use de command "USE ..\myfolder\users.dbf INDEX ..\myfolder\users.cdx" from a foxpro table viewer and the index file is linked again.
Is there any way to use this command from vb6?
Thank you
Some code clipped from an old demo:
CN.Open "Provider=VFPOLEDB.1;Data Source='" _
& App.Path _
& "';Mode=ReadWrite|Share Deny None;Deleted=True"
With CN
.Execute "ExecScript('USE DemoTable EXCLUSIVE" & vbCr _
& "INDEX ON CustNumber TAG CustIX" & vbCr _
& "INDEX ON DELETED() TAG DELETED BINARY')", _
, _
adCmdText Or adExecuteNoRecords
'Resume sharing:
.Execute "ExecScript('USE DemoTable SHARED')", _
, _
adCmdText Or adExecuteNoRecords
End With
Point being that you can use ExecScript for such things.
I have been using this site for a while and it has been really useful for me. First of all I want to thank all contributors for this. However I faced a problem and could not find a solution for that.
I'm not a professional coder or programmer, I am only using excel VBA to improve some reporting tools which we use at work. That is why I may have done really basic mistakes, please do not hate me :)
So, I am trying to create basic inventory follow-up tool which is going to contain some part numbers in the main sheet (Followup Sheet) and every day responsible is going to paste some values to incoming sheet (WebDOS Pivot), with my macro I am planning to look for incoming part numbers within existing ones and if it is there input the incoming value to the related cell.
My .find function is working good, however when I add the code to copy the value to related cell macro starts to run really slow. Do you guys have any idea what I am doing wrong, or how can I improve the performance of this code? Thank you in advance.
Dim WebDOSLastRow As Long
Dim WDS As Worksheet
Dim FUS As Worksheet
Dim PUS As Worksheet
Dim SearchResult As Range
Set WDS = Sheets("WebDOS Pivot")
Set FUS = Sheets("Followup Sheet")
Set PUS = Sheets("Part Usage Pivot")
WebDOSLastRow = WDS.Range("A3").End(xlDown).Row
For i = 5 To WebDOSLastRow - 1
With FUS.Range("E:E")
Set SearchResult = .Find(What:=WDS.Range("A" & i).Value, _
After:=Range("E5"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not SearchResult Is Nothing Then
FUS.Range("K" & SearchResult.Row).Value = WDS.Range("C" & i).Value + FUS.Range("K" & SearchResult.Row).Value
Else
'Coding Will Come Here for not found items
End If
End With
Application.StatusBar = "Searching " & i & "/" & WebDOSLastRow
Next
Application.StatusBar = False
End Sub
I have managed to solve my problem right after posting here, which shows that I did not try hard before :), so simply switching to manual calculation solved slow running problem. Here is the new code.
WebDOSLastRow = WDS.Range("A3").End(xlDown).Row
Application.Calculation = xlCalculationManual '<---- Switching to manual calculation
For i = 5 To WebDOSLastRow - 1
With FUS.Range("E:E")
Set SearchResult = .Find(What:=WDS.Range("A" & i).Value, _
After:=Range("E5"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not SearchResult Is Nothing Then
FUS.Range("K" & SearchResult.Row).Value = WDS.Range("C" & i).Value + FUS.Range("K" & SearchResult.Row).Value
Else
'Coding Will Come Here for not found items
End If
End With
Application.StatusBar = "Searching " & i & "/" & WebDOSLastRow
Next
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic