The following code is supposed to copy information from xlsx files(inside subfolders) and consolidate(paste) everything in a single file:
Dim xlApp, xlApp1, xlApp2 As Excel.Application
Dim xlWorkBook, xlWorkBook1, xlWorkBook2 As Excel.Workbook
Dim xlWorkSheet, xlWorkSheet1, xlWorkSheet2 As Excel.Worksheet
Dim folder, m, n As String
Dim subfolders As String()
Dim i, j, c, k, l, lastrow As Integer
Dim fec As Date
folder = My.Application.Info.DirectoryPath
ChDir(CurDir())
subfolders = IO.Directory.GetDirectories(CurDir())
xlApp = New Excel.ApplicationClass
xlApp2 = New Excel.ApplicationClass
xlApp1 = New Excel.ApplicationClass
Try
xlWorkBook = xlApp.Workbooks.Open("\\excel1.xlsx")
xlWorkSheet = xlWorkBook.Worksheets("SheetName")
xlWorkBook2 = xlApp2.Workbooks.Open("\\excel2.xlsx")
xlWorkSheet2 = xlWorkBook2.Worksheets("SheetName")
i = 2
For Each f1 In subfolders
ChDir(f1)
m = Dir("*.xlsx")
Do While m <> ""
j = 1
Do While xlWorkSheet2.Cells(j, 1).Value <> ""
If xlWorkSheet2.Cells(j, 1).Value = m Then
fec = xlWorkSheet2.Cells(j, 2).value
If fec <> File.GetLastWriteTime(CurDir() & "\" & m) Then
l = 1
n = xlWorkSheet.Cells(l, 3).value()
Do While n <> ""
If Trim(xlWorkSheet.Cells(l, 3).value) = Strings.Left(Strings.Right(m, 16), 11) Then
xlWorkBook.Activate()
xlWorkSheet.Rows(l).delete()
If Trim(xlWorkSheet.Cells(l, 3).value()) <> Strings.Left(Strings.Right(m, 16), 11) Then
n = ""
End If
Else
l = l + 1
n = xlWorkSheet.Cells(l, 3).value()
End If
Loop
xlWorkBook1 = xlApp1.Workbooks.Open(CurDir() & "\" & m)
xlWorkSheet1 = xlWorkBook1.Worksheets("Test")
xlWorkSheet1.Visible = True
xlWorkSheet1.Activate()
xlWorkSheet1.Select()
If xlWorkSheet1.FilterMode = True Then
xlWorkSheet1.ShowAllData()
End If
c = 5
Do While Trim(xlWorkSheet1.Cells(c, 4).value) <> "Entity Name"
c = c + 1
Loop
c = c + 2
If xlWorkSheet1.Cells(c, 4).value <> "" Then
xlWorkSheet2.Cells(j, 2) = File.GetLastWriteTime(CurDir() & "\" & m)
lastrow = xlWorkSheet1.Cells(65536, 3).End(Excel.XlDirection.xlUp).Row
xlWorkSheet.Cells(l, 1).Insert(Excel.XlInsertShiftDirection.xlShiftDown, xlWorkSheet1.Range("a" & c.ToString, xlWorkSheet1.Cells(lastrow, 42)).Copy())
End If
xlWorkBook1.Close()
releaseObject(xlWorkBook1)
releaseObject(xlWorkSheet1)
End If
j = j + 1000
ElseIf xlWorkSheet2.Cells(j + 1, 1).Value = "" Then
k = j + 1
xlWorkSheet2.Range("A" & k.ToString).Value = m
xlWorkSheet2.Range("B" & k.ToString).Value = "01/01/2000"
End If
j = j + 1
Loop
m = Dir()
Loop
Next
xlWorkBook2.Close()
xlWorkBook.Close()
xlApp.Quit()
xlApp2.Quit()
xlApp1.Quit()
Catch ex As Exception
...
But after this line
xlWorkSheet.Cells(l, 1).Insert(Excel.XlInsertShiftDirection.xlShiftDown, xlWorkSheet1.Range("a" & c.ToString, xlWorkSheet1.Cells(lastrow, 42)).Copy())
it fails showing the error:
System.Runtime.InteropServices.COMException(0x800A03EC): Insert Method of range class failed.
Excel files are ok, with write permissions and are local.
Any ideas?
Related
I hope some of you can help with the code under these text, I can export Attachments which are in the body of an Lotus Notes Mail, but also I need to export them, when they aren't in the body (like "normal" attachments).
Set LNItem = doc.GETFIRSTITEM("Body")
If doc.HasEmbedded Then
int_Anhang = 1
x = 0
Worksheets("Mails").Cells(j, 3).Value = 0
On Error Resume Next
For Each LNAttachment In LNItem.EmbeddedObjects
y = 0
AttPath = ActiveWorkbook.path & "1-Weiterleitung_Mail-Anhang" & y & "-" + LNAttachment.Name
While Dir(AttPath) <> ""
y = y + 1
AttPath = ActiveWorkbook.path & "1-Weiterleitung_Mail-Anhang" & y & "-" + LNAttachment.Name
Wend
LNAttachment.ExtractFile (AttPath)
Worksheets("Mails").Cells(j, 3).Value = Worksheets("Mails").Cells(j, 3).Value + 1
Worksheets("Mails").Cells(j, 7 + x).Value = y & "-" + LNAttachment.Name
x = x + 1
Next
On Error GoTo Fehler
Debug.Print vbNewLine
End If
Can someone help?
My Question in other communities:
ms-office-forum.net
Herber.de
Here are more code:
Dim sess As Object, db As Object, folder As Object, dc As Object, docMemo As Object, docNext As Object, LNItem As Object
Dim memoSenders As Variant, memoAnhang As Variant, memoInhalt As Variant, memoLayout As Variant, LNAttachment As Variant
Dim memoDate As Date, todayDate As Date
Dim mail_Server As String, mail_Datei As String, memoSubject As String, AttPath As String
Dim y As Integer, int_test As Integer
'On Error GoTo Fehler_Notes
On Error GoTo Fehler
Set sess = CreateObject("Notes.NotesSession")
'sess.Initialize ("")
'On Error GoTo Fehler
mail_Server = Worksheets("Daten").Cells(2, 2).Value
mail_Datei = Worksheets("Daten").Cells(2, 3).Value
'Open the mail database in notes
Set db = sess.GetDatabase(mail_Server, mail_Datei)
If db.IsOpen = True Then
'Already open for mail
Else
db.OPENMAIL
End If
int_test = 0
Do While Worksheets("Daten").Cells(i, 6).Value <> ""
Set folder = db.GetView(Worksheets("Daten").Cells(i, 6).Value)
If Worksheets("Daten").Cells(i, 9).Value <> "" Then
todayDate = Worksheets("Daten").Cells(i, 9).Value
Else
Worksheets("Daten").Cells(i, 9).Value = "01.01.2000 00:00"
todayDate = Worksheets("Daten").Cells(i, 9).Value
End If
Set doc = folder.GetFirstDocument
Do Until doc Is Nothing
Set docNext = folder.GetNextDocument(doc)
'Datum des Empfangs
Worksheets("Daten").Cells(29, 2).Value = doc.GetItemValue("DeliveredDate")
memoDate = Worksheets("Daten").Cells(29, 2).Value
int_test = int_test + 1
int_xxx = int_xxx + 1
memoSenders = doc.GetItemValue("From")
memoInhalt = doc.GetItemValue("Body")
memoLayout = doc.GetItemValue("Form")
memoSubject = doc.GetItemValue("Subject")(0)
Worksheets("Mails").Cells(j, 1).Value = i - 2
Worksheets("Mails").Cells(j, 2).Value = memoSenders
Worksheets("Mails").Cells(j, 4).Value = memoInhalt
Worksheets("Mails").Cells(j, 5).Value = memoLayout
Worksheets("Mails").Cells(j, 6).Value = memoSubject
'Prüfen ob Attachments innerhalb der Mail vorhanden sind
Set LNItem = doc.GETFIRSTITEM("Body")
If doc.HasEmbedded Then
int_Anhang = 1
x = 0
Worksheets("Mails").Cells(j, 3).Value = 0
On Error Resume Next
For Each LNAttachment In doc.EmbeddedObjects
y = 0
AttPath = ActiveWorkbook.path & "\01-Weiterleitung_Mail-Anhang\" & y & "-" + LNAttachment.Name
While Dir(AttPath) <> ""
y = y + 1
AttPath = ActiveWorkbook.path & "\01-Weiterleitung_Mail-Anhang\" & y & "-" + LNAttachment.Name
Wend
LNAttachment.ExtractFile (AttPath)
Worksheets("Mails").Cells(j, 3).Value = Worksheets("Mails").Cells(j, 3).Value + 1
Worksheets("Mails").Cells(j, 7 + x).Value = y & "-" + LNAttachment.Name
x = x + 1
Next
On Error GoTo Fehler
Debug.Print vbNewLine
End If
Call doc.PutInFolder(Worksheets("Daten").Cells(6, 3).Value)
Call doc.MarkRead
Call doc.RemoveFromFolder(Worksheets("Daten").Cells(i, 6).Value)
j = j + 1
Set doc = docNext
Loop
Worksheets("Daten").Cells(i, 9).Value = CStr(Format(Now, "MM/DD/YYYY hh:mm"))
i = i + 1
Loop
If int_test <> 0 Then
i = 3
ReadNotesEmail i, j
End If
int_error = 0
Exit Sub
Regards
NotesDocument has also a property EmbeddedObjects.
You can use it this way:
For Each LNAttachment In doc.EmbeddedObjects
...
Next
I've try to make the code from Duston work in Excel VBA:
Set Item = Doc.GetFirstItem("$file")
If LCase(Item.Name) = "$file" Then
Set FileItem = Item
FileName = FileItem.Values(0)
Set Object = Doc.GetAttachment(FileName)
AttPath = ActiveWorkbook.path & "\01-Weiterleitung_Mail-Anhang\" & "1" & "-"
' extract the file ..
Call Object.ExtractFile(AttPath & FileName)
End If
My code produce no error and the script goes into the If-Case, but nothing happens. (The "Filename" is empty)
check for File name and you can get the embededobject
this is the java code:
String path="";
Vector fileName= session.evaluate("#AttachmentNames", document);
for (int i = 0; i < fileName.size(); i++) {
EmbeddedObject embeddedObject =
document.getAttachment(fileName.get(i));
embeddedObject .extractFile(path+fileName.get(i));
}
Also check for items named $File. Some sample code is located in this link:
http://www.richardcivil.net/archives/157
In particular:
If Lcase( item.Name ) = "$file" Then
' get the filename ...
Set FileItem = Item
FileName = FileItem.Values(0)
Set Object = sourceDoc.GetAttachment( FileName )
' extract the file ..
Call object.ExtractFile( tempDir & FileName )
' upload the file ..
Set newObject = attachmentBody.EmbedObject( object.Type, "", tempDir & FileName )
' kill the file ..
Kill tempDir & FileName
End If
So I did a very simple loop VBA to consolidate data from different workbook into single workbook. I got the out of range error keep promting me and I've tried my best to think but it's a dead end for me. Appreciate if can get some input from the seniors.
Sub consolidate()
Application.ScreenUpdating = False
Set mb = ThisWorkbook
myfdr = ThisWorkbook.Path
fname = Dir(myfdr & "\*.csv")
Do Until fname = Empty
If fname <> mb.Name Then
Set wb = Workbooks.Open(myfdr & "\" & fname)
mg = Range("A1").End(xlDown).Row
Range("M4").Value = mg
wb.Worksheets.Copy After:=mb.Sheets(mb.Sheets.Count)
wb.Close SaveChanges:=False
n = n + 1
End If
fname = Dir
Loop
Application.ScreenUpdating = True
MsgBox n & "Done"
End Sub
Sub Union()
Application.ScreenUpdating = False
Set ms = Worksheets("Sheet1")
fsn = 1
k = 0
Set mb = ThisWorkbook
myfdr = ThisWorkbook.Path
fname = Dir(myfdr & "\*.csv")
Do Until fname = Empty
If fname <> mb.Name Then
sn = Mid(fname, 1, Len(fname) - 4)
Set cs = Worksheets(sn) '<<<<The subscript out of range error happened here
If fsn = 1 Then
fsn = 0
For g = 1 To cs.Cells(4, 13)
k = k + 1
For r = 1 To 10
ms.Cells(k, r) = cs.Cells(g, r)
Next r
Next g
Else
For g = 9 To cs.Cells(4, 13)
k = k + 1
For r = 1 To 10
ms.Cells(k, r) = cs.Cells(g, r)
Next r
Next g
End If
End If
fname = Dir
Loop
End Sub
I have 2 tables as shown below
Table 1
AA
BB
CC
DD
EE
Table 2
bb
aa
bb1
bb2
cc1
cc2
cc3
I need help to do the below steps using Excel VBA code
Use Table 1 and loop thru each data in table 1 and compare to Table 2
If table 2 only have 1 match, just replace the Table 1 data from the table 2 value on the same row of data from table 1
If have multiple match from table 2, them prompt user to select which data from table 2 need to be written in table 1
Matching Criteria are as follows
AA should match to aa,aa1,aa2,,,,,,
BB shoud match bb,bb1,bb2,,,,,,,,
Below is the code that I have written
Private Sub CommandButton2_Click()
Dim attr1 As Range, data1 As Range
Dim item1, item2, item3, lastRow, lastRow2
Dim UsrInput, UsrInput2 As Variant
Dim Cnt As Integer, LineCnt As Integer
Dim MatchData(1 To 9000) As String
Dim i As Integer, n As Integer, j As Integer, p As Integer
Dim counter1 As Integer, counter2 As Integer
Dim match1(1 To 500) As Integer
Dim matchstr1(1 To 500) As String
Dim tmpstr1(1 To 500) As String
Dim storestr(1 To 500) As String
Dim tmpholderstr As String
counter1 = 1
counter2 = 0
j = 0
p = 0
tmpholderstr = ""
For i = 1 To 500
storestr(i) = ""
Next i
For i = 1 To 500
tmpstr1(i) = ""
Next i
For i = 1 To 500
matchstr1(i) = ""
Next i
For i = 1 To 500
match1(i) = 0
Next i
For i = 1 To 9000
MatchData(i) = ""
Next i
UsrInput = InputBox("Enter Atribute Column")
UsrInput2 = InputBox("Enter Column Alphabet to compare")
With ActiveSheet
lastRow = .Cells(.Rows.Count, UsrInput).End(xlUp).Row
'MsgBox lastRow
End With
With ActiveSheet
lastRow2 = .Cells(.Rows.Count, UsrInput2).End(xlUp).Row
'MsgBox lastRow
End With
Set attr1 = Range(UsrInput & "2:" & UsrInput & lastRow)
Set data1 = Range(UsrInput2 & "2:" & UsrInput2 & lastRow2)
'Debug.Print lastRow
'Debug.Print lastRow2
For Each item1 In attr1
item1.Value = Replace(item1.Value, " ", "")
Next item1
For Each item1 In attr1
If item1.Value = "" Then Exit For
counter1 = counter1 + 1
item1.Value = "*" & item1.Value & "*"
For Each item2 In data1
If item2 = "" Then Exit For
If item2 Like item1.Value Then
counter2 = counter2 + 1
match1(counter2) = counter1
matchstr1(counter2) = item2.Value
tmpstr1(counter2) = item1.Value
Debug.Print item1.Row
Debug.Print "match1[" & counter2; "] = " & match1(counter2)
Debug.Print "matchstr1[" & counter2; "] = " & matchstr1(counter2)
Debug.Print "tmpstr1[" & counter2; "] = " & tmpstr1(counter2)
End If
Next item2
Next item1
' Below is the code that go thru the array and try to write to table 1
' But it is not working as expected.
For n = 1 To 500
If matchstr1(n) = "" Then Exit For
If match1(n) <> match1(n + 1) Then
Range("K" & match1(n)) = matchstr1(n)
Else
i = 0
For j = n To 300
If matchstr1(j) = "" Then Exit For
i = i + 1
If match1(j) = match1(j + 1) Then
tmpstr1(i) = matchstr1(j)
End If
Next j
End If
Next n
End Sub
Try the following. Your two tables are suppose to be in a sheet named "MyData", where there is also a command button (CommandButton2). Add also a UserForm (UserForm1), and in that UserForm add another command button (CommandButton1).
In the module associated with CommandButton2, copy the following code:
Public vMyReplacementArray() As Variant
Public iNumberOfItems As Integer
Public vUsrInput As Variant, vUsrInput2 As Variant
Public lLastRow As Long, lLastRow2 As Long
Public rAttr1 As Range, rData1 As Range, rItem1 As Range, rItem2 As Range
Public iCounter1 As Integer
Sub Button2_Click()
vUsrInput = InputBox("Enter Atribute Column")
vUsrInput2 = InputBox("Enter Column Alphabet to compare")
With ActiveSheet
lLastRow = .Cells(.Rows.Count, vUsrInput).End(xlUp).Row
End With
With ActiveSheet
lLastRow2 = .Cells(.Rows.Count, vUsrInput2).End(xlUp).Row
End With
Set rAttr1 = Range(vUsrInput & "2:" & vUsrInput & lLastRow)
Set rData1 = Range(vUsrInput2 & "2:" & vUsrInput2 & lLastRow2)
ReDim vMyReplacementArray(1 To 1) As Variant
For Each rItem1 In rAttr1
For Each rItem2 In rData1
If (InStr(1, rItem2, rItem1, vbTextCompare)) > 0 Then
vMyReplacementArray(UBound(vMyReplacementArray)) = rItem1.Value & "-" & rItem2.Value
ReDim Preserve vMyReplacementArray(1 To UBound(vMyReplacementArray) + 1) As Variant
End If
Next rItem2
Next rItem1
iNumberOfItems = UBound(vMyReplacementArray) - LBound(vMyReplacementArray)
UserForm1.Show
End Sub
And in the Userform, the following:
Dim k As Integer
Private Sub UserForm_initialize()
Dim myElements() As String
Dim theLabel As Object
Dim rad As Object
Class1 = ""
k = 1
For i = 1 To iNumberOfItems
myElements = Split(vMyReplacementArray(i), "-")
If myElements(0) <> Class1 Then
Set theLabel = UserForm1.Controls.Add("Forms.Label.1", "Test" & i, True)
theLabel.Caption = myElements(0)
theLabel.Left = 80 * k
theLabel.Width = 20
theLabel.Top = 10
k = k + 1
j = 1
End If
Set rad = UserForm1.Controls.Add("Forms.OptionButton.1", "radio" & j, True)
If j = 1 Then
rad.Value = True
End If
rad.Caption = myElements(1)
rad.Left = 80 * (k - 1)
rad.Width = 60
rad.GroupName = k - 1
rad.Top = 50 + 20 * j
j = j + 1
Class1 = myElements(0)
Next i
End Sub
Private Sub CommandButton1_Click()
Dim ctrl As MSForms.Control
Dim dict(5, 1)
Dim i
'## Iterate the controls, and associates the GroupName to the Button.Name that's true.
i = 0
For Each ctrl In Me.Controls
If TypeName(ctrl) = "OptionButton" Then
If ctrl.Value = True Then
dict(i, 0) = ctrl.GroupName
dict(i, 1) = ctrl.Caption
i = i + 1
End If
End If
Next
'For i = 0 To k
'MsgBox "grupo: " & dict(i, 0) & "elem: " & dict(i, 1)
'Next
j = 0
For i = 1 To iNumberOfItems
myElements = Split(vMyReplacementArray(i), "-")
For Each rItem1 In rAttr1
If rItem1 = myElements(0) Then
rItem1 = dict(j, 1)
j = j + 1
End If
Next
Next i
End Sub
I've made a code that copy values between workbooks.
The problem is it is too slow (it takes almost 30 minutes to copy to 60 files).
I think it's because I set value for each cell.
For Each cl In rg
For c = 0 To 4
wb.ActiveSheet.Cells(i + c, 2 + n).Value = cl.Offset(r - 2, c).Value
Next
n = n + 1
Next
The reason I do it is the task: there are 60 rows of cells (there is a formula in each cell) (550 cells in each row). Values (results, not formulas) of first row must be copied to the first excel workbook (there are 60 files), second row to the second workbook, etc. This row is copied in the table 5x110 where data is filled by columns (first 5 cells of the row - is the first column, etc.).
How to optimize this? (I've tried copy - past values - becomes not responding).
I've already done opening Excel Application in invisible mode.
I haven't tried to write to the closed excel file (without opening it) yet (but I think it will not become working much faster)
Sub CopyM()
Dim rg As Range, r As Long, c As Long, wb As Excel.Workbook, col As Long, i As Long, j(1 To 60) As String, k As Long
Dim FileName As String
Dim app As New Excel.Application
Dim FolderPath As String, p As String, cl As Range, n As Long
app.Visible = False
i = 2
For k = 1 To 60
If k < 51 Then
j(k) = k
Else
j(k) = ("d" & (k - 50))
End If
Next k
Set rg = Range("K2")
Application.ScreenUpdating = False
For col = 16 To 560 Step 5
Set rg = Union(rg, Cells(2, col))
Next col
p = ActiveWorkbook.Path
FolderPath = (p & "\")
FileName = (FolderPath & j(1) & ".xlsm")
n = 0
For r = 2 To 61
FileName = (FolderPath & j(r - 1) & ".xlsm")
Set wb = app.Workbooks.Open(FileName)
n = 0
For Each cl In rg
For c = 0 To 4
wb.ActiveSheet.Cells(i + c, 2 + n).Value = cl.Offset(r - 2, c).Value
Next
n = n + 1
Next
wb.Close savechanges:=True
app.Quit
Application.ScreenUpdating = True
Cells(1, 1).Value = (r - 1) & "/60"
Application.ScreenUpdating = False
Next
Set app = Nothing
Application.ScreenUpdating = True
Cells(1, 1).Value = ""
MsgBox "Finished"
End Sub
That's awesome!!
The time of execution significantly reduced to 3 minutes 19 seconds!
Thank you #chrisneilsen for suggestion!
Here is the edited code:
Sub CopyM()
Dim r As Long, wb As Excel.Workbook, i As Long, p As String, n As Long
Dim FileName As String, j(1 To 60) As String, k As Long
Dim app As New Excel.Application
Dim FolderPath As String, ai As Variant, bi(1 To 5, 1 To 110) As Variant
app.Visible = False
For k = 1 To 60
If k < 51 Then
j(k) = k
Else
j(k) = ("d" & (k - 50))
End If
Next k
Application.ScreenUpdating = False
p = ActiveWorkbook.Path
FolderPath = (p & "\")
FileName = (FolderPath & j(1) & ".xlsm")
r = 2
i = 0
n = 1
For r = 2 To 61
ai = Range(Cells(r, 11), Cells(r, 560)).Value
i = 0
n = 1
For i = 1 To 550 Step 5
bi(1, n) = ai(1, i)
bi(2, n) = ai(1, 1 + i)
bi(3, n) = ai(1, 2 + i)
bi(4, n) = ai(1, 3 + i)
bi(5, n) = ai(1, 4 + i)
n = n + 1
Next
FileName = (FolderPath & j(r - 1) & ".xlsm")
Set wb = app.Workbooks.Open(FileName)
wb.ActiveSheet.Range("B2:DG6").Value = bi
wb.Close savechanges:=True
app.Quit
Application.ScreenUpdating = True
Cells(1, 1).Value = (r - 1) & "/60"
Application.ScreenUpdating = False
Next
Set app = Nothing
Application.ScreenUpdating = True
Cells(1, 1).Value = ""
MsgBox "Finished"
End Sub
I've just gotten into programming VBA, and have very little other programming experience.
I'll first describe the intention of the macro:
So, there are an x number of excel files with data in them. All these files follow the same basic design:
Column A contains the 'name' of the data I want. There are ten rows with different names.
Column M contains the data corresponding to the name of column A (an average value of the columns in between)
This average data has to be transferred to a 'master' excel file.
I've made a userform to select the files that need to be imported, which appears to work fine (at least selecting the files)
I call the userform within my module using
usrform.show
As said, I'm able to run the userform. Just when I click apply within the userform, it stops the code and opens the excel vba editor and displays the graphical userform.
No idea what's causing this. Do Any of you have input?
Public strListe_selected() As String
Public booDatenAbbrechen As Boolean
Sub Ergebnisse_einlesen()
Dim datei As String
Dim liste As String
Dim test As Variant
Dim name As String
Dim nPh As Integer
Dim Suche As String
Dim Excel_Daten() As Variant
Dim rngFound As Range
Dim rngFound1 As Range
Dim Komponente() As String
Dim startreihe As Integer
Dim SMK As String
Dim dateinr As Integer
Dim strdatumformatiert As String
Dim strerstellungsdatum() As String
Dim intantwort As Integer
Dim strdatum As String
Dim Phase As String
'*************************************Zeit messen um Einlesezeit zu optimieren
Dim t
t = Now
'*************************************Zeile controlieren, somit kein daten in die falsche zeile kommt
startreihe = ActiveCell.Row
If startreihe < 10 Then
MsgBox "Bitte markieren sie die Zeile in der die neuen Testdaten eingetragen werden sollen und führen sie das Makro erneut aus"
Exit Sub
ElseIf Cells(startreihe, 3) <> "" Then
antwort = MsgBox("Die markierte Zeile enthält bereits Daten, wollen sie diese überschreiben?", vbOKCancel)
If antwort = vbCancel Then Exit Sub
End If
'************************************Sammeln von Informationen über diese Arbeitsmappe
liste = ThisWorkbook.ActiveSheet.name
letztespalte = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
name = ThisWorkbook.name
'************************************Dialogfenster öffnen
xls_suchen.Show
If booDatenAbbrechen = True Then Exit Sub
For dateinr = 0 To UBound(strListe_selected) 'Schleife über die gewählten xls-Dateien
Application.ScreenUpdating = False 'Bildschirmanzeige unterdrücken
Workbooks.Open Filename:=Element & strListe_selected(dateinr) 'öffnen der xls-Datei
'**********************************************************************************************************************
'neudimensionieren des ARRAYs
c = 4
emdat = anzkomp * (c + 1)
ReDim Excel_Daten(24 + emdat, 3)
'Spaltenüberschrift des Arrays "Excel_Daten" festlegen
Excel_Daten(0, 0) = "Name"
Excel_Daten(0, 1) = "Reihe"
Excel_Daten(0, 2) = "Spalte"
Excel_Daten(0, 3) = "Wert"
'**********************************************************************************************************************
'******************************** Daten aus der Excel-Datei lesen *******************************************************
i = 2
For k = 1 To anzkomp
Suche = Komponente(k)
Excel_Daten(i, 0) = Komponente(k)
Set rngFound = Cells.Find(What:="Bemerkung:")
test = Cells(rngFound.Row, rngFound.Column).Value
If test = "Bemerkung:" Then
anzkomp = 11
nPh = 1
ReDim Komponente(anzkomp)
Testergebnis = "Phase"
Komponente(1) = "F_eth"
Komponente(2) = "F_Lakor_m"
Komponente(3) = "F_lradap1c[0]"
Komponente(4) = "F_lradap1c[1]"
Komponente(5) = "F_lradap1c[2]"
Komponente(6) = "F_lradap1c[3]"
Komponente(7) = "F_lradap1c[4]"
Komponente(8) = "F_lradap1c[5]"
Komponente(9) = "F_lradap1c[6]"
Komponente(10) = "F_lradap1c[7]"
Komponente(11) = "Km_st_1"
Else
MsgBox "Der test ist nicht bekannt. Ist der Datei ein EDR Messdatei?"
End If
Set rngFound1 = Cells.Find(What:="Phase")
If rngFound1 Is Nothing Then
MsgBox Testergebnis & "nicht gefunden"
Else
Set rngFound = Cells.Find(What:=Suche, After:=Cells(rngFound1.Row, rngFound1.Column))
If rngFound Is Nothing Then
If Suche = "F_eth" Then n = 2
If Suche = "F_Lakor_m" Then n = 5
If Suche = "F_lradap1c[0]" Then n = 8
If Suche = "F_lradap1c[1]" Then n = 11
If Suche = "F_lradap1c[2]" Then n = 14
If Suche = "F_lradap1c[3]" Then n = 17
If Suche = "F_lradap1c[4]" Then n = 20
If Suche = "F_lradap1c[5]" Then n = 23
If Suche = "F_lradap1c[6]" Then n = 26
If Suche = "F_lradap1c[7]" Then n = 29
If Suche = "Km_st_1" Then n = 32
For i = n To n + 4
If i <> n Then Excel_Daten(i, 0) = Suche & "_PH" & i - n
Excel_Daten(1, 3) = ""
Next i
Else
Excel_Daten(i, 1) = rngFound.Row
Excel_Daten(i, 2) = rngFound.Column
Excel_Daten(i, 3) = Cells(rngFound.Row, rngFound.Column + 12).Value
i = i + 1
For j = 1 To c
If j > nPh Then
If Suche = "F_eth" Then n = 2
If Suche = "F_Lakor_m" Then n = 5
If Suche = "F_lradap1c[0]" Then n = 8
If Suche = "F_lradap1c[1]" Then n = 11
If Suche = "F_lradap1c[2]" Then n = 14
If Suche = "F_lradap1c[3]" Then n = 17
If Suche = "F_lradap1c[4]" Then n = 20
If Suche = "F_lradap1c[5]" Then n = 23
If Suche = "F_lradap1c[6]" Then n = 26
If Suche = "F_lradap1c[7]" Then n = 29
If Suche = "Km_st_1" Then n = 32
Excel_Daten(n + j, 0) = Suche & "_PH" & j
Excel_Daten(n + j, 3) = ""
i = i + 1
End If
Next j
End If
End If
Next k
'Einlesen der Ergebnisse abgeschlossen --> schließen der VTS-Datei
ActiveWorkbook.Close
'**********************************************************************************************
'**********************************************************************************************
'Daten in gewünschtes Tabellenblatt übertragen
For b = 1 To 12
ThisWorkbook.Worksheets(liste).Cells(startreihe, b + 1) = Excel_Daten(b, 3)
Next b
b = 12
For a = 13 To 10 + emdat
ThisWorkbook.Worksheets(liste).Cells(startreihe, b + 3) = Excel_Daten(a, 3)
If Excel_Daten(a, 0) = "GRAMS_KM_CO2" Or Excel_Daten(a, 0) = "GRAMS_MI_CO2" _
Or Excel_Daten(a, 0) = "FUEL_CONS_MPG" Or Excel_Daten(a, 0) = "FUEL_CONS_KPL" _
Or Excel_Daten(a, 0) = "FUEL_CONS_LP100K" Then
b = b
ElseIf Excel_Daten(a + 1, 0) = Excel_Daten(a, 0) & "_PH1" Then
b = b + 2
End If
For i = 1 To c
a = a + 1
b = b + 1
ThisWorkbook.Worksheets(liste).Cells(startreihe, b + 3) = Excel_Daten(a, 3)
Next i
b = b + 1
'If a < emdat + 10 Then
' If test = "US06V1_FE" And VTS_Daten(a + 1, 0) = "FUEL_CONS_MPG" Then B = B + 5
'End If
Next a
Application.ScreenUpdating = True 'Bildschirmanzeige zulassen
Next dateinr
End Sub
Userform:
Private Sub button_cancel_Click()
ReDim strListe_selected(0) 'Liste wird gelöscht
booDatenAbbrechen = True
Unload Me
End Sub
Private Sub button_all_Click()
With Me.ListBox1
For i = 0 To .ListCount - 1
ListBox1.Selected(i) = True
Next
End With
End Sub
Private Sub button_none_Click()
With Me.ListBox1
For i = 0 To .ListCount - 1
ListBox1.Selected(i) = False
Next
End With
End Sub
Private Sub button_apply_Click()
booDatenAbbrechen = False
With Me.ListBox1
liste = .List
j = 0
For i = 0 To .ListCount - 1
If .Selected(i) Then
ReDim Preserve strListe_selected(j)
strListe_selected(j) = liste(i, 0)
j = j + 1
End If
Next
End With
Unload Me
End Sub
Private Sub button_add_file_Click()
add_files
End Sub
Private Sub button_add_folder_Click()
add_folder
End Sub
Sub add_folder()
Dim objAppShell As Object
Dim varBrowseDir As Variant
Dim strPfad As String
Dim varUnterordner As Variant
Dim objFileSystem As Object
Dim varOrdner As Variant
Dim Element
Dim strFilelist() As String
Dim i As Integer
Dim strFile As String
Dim FD As FileDialog
Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
.AllowMultiSelect = True
If Application.FileDialog(msoFileDialogFolderPicker).Show = 0 Then
Else
strPfad = .SelectedItems(1)
End If
End With
If strPfad = "" Then Exit Sub
'Ordner nach *.xls-Dateien durchsuchen
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set varOrdner = objFileSystem.GetFolder(strPfad)
Set varUnterordner = varOrdner.SubFolders
i = 0
ReDim Preserve strFilelist(i)
'Hauptordner durchsuchen
strFile = Dir(strPfad & "\" & "*.xls") 'Ersten Eintrag wählen
Do While strFile <> ""
strFilelist(i) = strPfad & "\" & strFile
ListBox1.AddItem (strFilelist(i))
i = i + 1
ReDim Preserve strFilelist(i)
strFile = Dir 'strFile = Dir 'Get nächsten Eintrag.
Loop
'Unterordner durchsuchen
For Each Element In varUnterordner
strFile = Dir(strPfad & "\" & Element.name & "\" & "*.xls")
Do While strFile <> ""
ReDim Preserve strFilelist(i)
strFilelist(i) = strPfad & "\" & Element.name & "\" & strFile
ListBox1.AddItem (strFilelist(i))
i = i + 1
strFile = Dir 'strFile = Dir 'Get nächsten Eintrag.
Loop
Next
End Sub
Sub add_files()
Dim FD As FileDialog
Dim Element
Dim i As Integer
Set FD = Application.FileDialog(msoFileDialogOpen)
With FD
.AllowMultiSelect = True
'.InitialFileName = ActiveWorkbook.Path & "\*.xls"""
.Filters.Clear
.Filters.Add "Excel dateien", "*.xls"
End With
i = 1
If FD.Show = -1 Then
For Each Element In FD.SelectedItems
' datei = Dir(Element, "*.xls")
ListBox1.AddItem (FD.SelectedItems(i))
Next
End If
End Sub