CsJHUN
Active Member
- Joined
- Jan 13, 2015
- Messages
- 360
- Office Version
- 365
- 2021
- 2019
- Platform
- Windows
- Mobile
Hi guys!
I wrote this, and got some useful info from here(i guess ) now I would like to ask you to give me any optimalization ideas (shortening the code, or runtime)
The task for this macro are:
This is how I "patched" together:
' dont bother with the comment lines, I made it for me - while constructing - and for the "enduser"
There is a Clearing step in the beginning of the code, was useful for test
The code currently work as I wanted under Win7 and MSO2010, I'm wondering ... already wrote in the 2nd line.
Thx for help in advance
I wrote this, and got some useful info from here(i guess ) now I would like to ask you to give me any optimalization ideas (shortening the code, or runtime)
The task for this macro are:
- let user select files via "Open" window
- open/close each file
- copy and paste selected datas below each other (copy from A2:right&down and paste into the macro workbook "data" sheet )
- loop 2&3 by the numbers of selected files
- delete duplicated rows (datas, currently based on column 1 and 5)
This is how I "patched" together:
- Show the "Open file" dialogbox
- let user select one or multiple (basically any, but planned for) excel files
- write file paths downwards from E2
- get file names from path downwards from F2
- Open the data file - copy data - open the macro workbook - get the first empty cell on "A" - paste data - close data file
- loop 5. by the numbers of selected files
- delete duplicated rows
- delete first (empty) row
' dont bother with the comment lines, I made it for me - while constructing - and for the "enduser"
There is a Clearing step in the beginning of the code, was useful for test
The code currently work as I wanted under Win7 and MSO2010, I'm wondering ... already wrote in the 2nd line.
Thx for help in advance
Code:
Sub tobb_file_osszefuzo()
Dim intChoice, lastrow As Integer
Dim strPath As String
Dim i, u As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'takarít
Columns("E:F").Select
Selection.Clear
ThisWorkbook.Sheets("data").Select
Cells.Select
Selection.Clear
'fájl megnyitás ablak + E2-től lefele fájlok elérése
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = True
intChoice = Application.FileDialog(msoFileDialogOpen).Show
If intChoice <> 0 Then
For i = 1 To Application.FileDialog(msoFileDialogOpen).SelectedItems.Count
strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(i)
Cells(i + 1, 5) = strPath
Next i
End If
'F2-től lefele fájlnevek képlet alapján
Do
i = i - 1
Cells(i + 1, 5).Select
Set acl = ActiveCell
'acl.Offset(0, 1).FormulaR1C1 = "=TRIM(RIGHT(SUBSTITUTE(RC[-1],""\"",REPT("" "",99)),99))" '.xls a végén
acl.Offset(0, 1).FormulaR1C1 = "=LEFT(TRIM(RIGHT(SUBSTITUTE(RC[-1],""\"",REPT("" "",99)),99)),LEN(TRIM(RIGHT(SUBSTITUTE(RC[-1],""\"",REPT("" "",99)),99)))-4)"
Loop Until i = 1
'''''' tényleges másolás. Megnyitja az első fájl, átmásolja az adatot, bezárja a fájlt,
'''''' majd következő:megnyit, másol, lastrow, beilleszt. Utolsó fájl után duplikált törlés
'''''' az 1 és 5 oszlopokat összevetve, 1-es sor törlése
u = Application.FileDialog(msoFileDialogOpen).SelectedItems.Count + 1
Do
u = u - 1
Dim awbk As Variant
awbk = Cells(u + 1, 6)
Set dtst = ThisWorkbook.Sheets("data")
Set main = ThisWorkbook.Sheets("main")
Workbooks.Open (awbk)
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ThisWorkbook.Activate
Sheets("data").Select
lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & lastrow).Select
ActiveSheet.Paste
Windows(awbk).Activate
ActiveWindow.Close
ThisWorkbook.Sheets("main").Select
Loop Until u = 1
Sheets("data").Select
'Rows("2:2").Select
'Selection.Copy
'Range("A1").Select
'ActiveSheet.Paste
lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Range("A2").Select
ActiveSheet.Range("$A$2:$CF$" & lastrow).RemoveDuplicates Columns:=Array(1, 5), Header:=xlNo
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub