-1
Ich habe einen Code, der mehrere Dateien (> 100) durchläuft. Es öffnet die Datei und fügt diese Information einem Array hinzu. Bei jeder neuen Datei kann sich die Anzahl der Elemente in den Zeilen ändern (erhöhen oder verringern). Ich verwende ein zweites Array, um das zu erklären.Gehen durch Spalten in einem Array und Kopieren der Daten
Die Spaltenüberschriften ändern sich auch in den Dateien (Überschriften in verschiedenen Spaltenpositionen). Mein Problem ist, dass ich versuche, durch die Spalten in der ersten Zeile (Header) zu gehen, um zu sehen, ob sie sich in diesem Dateiarray befinden, und wenn ja, kopiere diese Information in die Ausgabedatei (wenn nicht, setze ein " - ").
Aktuelle Code ist:
Sub Price()
Dim w As Workbook
Dim w2 As Workbook
Dim start1 As Long, end1 As Long, i As Long, lRow As Long, lColumn As Long, t As Long, k As Long, position As Long, g As Long, p As Long, u As Long
Dim WBArray() As Variant
Dim r As Range
Dim Header(): ReDim Header(0)
Dim IS3(): ReDim IS3(0) 'this fix the subscript out of range error
Dim ws As Worksheet
Dim MyFolder As String
Dim MyFile As String
Set w = ThisWorkbook
'clean all worksheets in the main file (except FILES)
For Each ws In w.Worksheets
If ws.Name <> "FILES" Then
ws.UsedRange.ClearContents
End If
Next ws
'Optimize Macro Speed Start
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'opens the first workbook file
For i = 2 To ThisWorkbook.Sheets("FILES").Cells(1, 2).Value
Workbooks.Open Filename:=ThisWorkbook.path & "\" & ThisWorkbook.Sheets("FILES").Cells(i, 1).Value
Set w2 = ActiveWorkbook
ActiveSheet.Range("A:A").Select
'text to columns
Selection.TextToColumns destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7 _
, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17 _
, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27 _
, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1)), TrailingMinusNumbers:=True
'create the array based on whanted data
With ActiveSheet
Set r = .Columns(1).Find(what:="ISIN", After:=.Cells(.Rows.count, 1), lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not r Is Nothing Then
start1 = r.Row
end1 = .Range("B" & Rows.count).End(xlUp).Row
WBArray = .Range(Cells(start1, 1), Cells(end1, 29)).Value
End If
End With
'loop to match information in two arrays
'option 1 ***************************************
For lColumn = 2 To UBound(WBArray)
If IsInArray((WBArray(1, lColumn)), Header) <> -1 Then
p = IsInArray((WBArray(1, lColumn)), Header)
'p is position when already in array
Else
ReDim Preserve Header(LBound(Header) To UBound(Header) + 1)
Header(UBound(Header)) = WBArray(1, lColumn)
u = UBound(Header)
'u is position when not in array, redim to end
End If
Next lColumn
For lRow = 2 To UBound(WBArray)
For lColumn = 2 To UBound(WBArray)
If IsInArray((WBArray(lRow, 1)), IS3) <> -1 Then
t = IsInArray((WBArray(lRow, 1)), IS3)
If lColumn.Name = "Cpn" Then
w.Sheets("Cpn").Cells(t, i + 3).Value = WBArray(lRow, lColumn)
Else
'w.Sheets("Cpn").Cells(t, i + 3).Value = "--"
Resume Next
End if
w.Sheets("M").Cells(t, i + 3) = WBArray(lRow, lColumn)
w.Sheets("W t-1").Cells(t, i + 3) = WBArray(lRow, lColumn)
w.Sheets("P").Cells(t, i + 3) = WBArray(lRow, lColumn)
w.Sheets("A").Cells(t, i + 3) = WBArray(lRow, lColumn)
w.Sheets("PC").Cells(t, i + 3) = WBArray(lRow, lColumn)
w.Sheets("AM").Cells(t, i + 3) = WBArray(lRow, lColumn)
w.Sheets("AM t-1").Cells(t, i + 3) = WBArray(lRow, lColumn)
w.Sheets("Pe t-1").Cells(t, i + 3) = WBArray(lRow, lColumn)
w.Sheets("F").Cells(t, i + 3) = WBArray(lRow, lColumn)
w.Sheets("F t-1").Cells(t, i + 3) = WBArray(lRow, lColumn)
w.Sheets("A t-1").Cells(t, i + 3) = WBArray(lRow, lColumn)
w.Sheets("S").Cells(t, i + 3) = WBArray(lRow, lColumn)
Else
'add it to the end of IS3Array
ReDim Preserve IS3(LBound(IS3) To UBound(IS3) + 1)
IS3(UBound(IS3)) = WBArray(lRow, 1)
k = UBound(IS3)
w.Sheets("C").Cells(k + 1, i + 3) = WBArray(lRow, lColumn)
w.Sheets("M").Cells(k + 1, i + 3) = WBArray(lRow, lColumn)
w.Sheets("W t-1").Cells(k + 1, i + 3) = WBArray(lRow, lColumn)
w.Sheets("P").Cells(k + 1, i + 3) = WBArray(lRow, lColumn)
w.Sheets("A").Cells(k + 1, i + 3) = WBArray(lRow, lColumn)
w.Sheets("PC").Cells(k + 1, i + 3) = WBArray(lRow, lColumn)
w.Sheets("AM").Cells(k + 1, i + 3) = WBArray(lRow, lColumn)
w.Sheets("AM t-1").Cells(k + 1, i + 3) = WBArray(lRow, lColumn)
w.Sheets("P t-1").Cells(k + 1, i + 3) = WBArray(lRow, 17)
w.Sheets("F").Cells(k + 1, i + 3) = WBArray(lRow, lColumn)
w.Sheets("F t-1").Cells(k + 1, i + 3) = WBArray(lRow, lColumn)
w.Sheets("A t-1").Cells(k + 1, i + 3) = WBArray(lRow, 18)
w.Sheets("S").Cells(k + 1, i + 3) = WBArray(lRow, lColumn)
End If
Next lColumn
Next lRow
'copy the file date from each source workbook to output workbook
'if the control sheet name (FILES) is changed, please change it in this loop
For Each ws In w.Worksheets
If ws.Name <> "FILES" Then
ws.Cells(1, i + 3) = w2.Worksheets(1).Cells(1, 2)
End If
Next ws
'Close file And Save
w2.Close True
Next i
'paste the is3 array to all worksheets
g = UBound(IS3)
For Each ws In w.Worksheets
If ws.Name <> "FILES" Then
ws.Range("A1:A" & g).Value = Application.WorksheetFunction.Transpose(IS3)
End If
Next ws
'Optimize Macro Speed
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Function
Public Function IsInArray(stringToBeFound As String, Arr As Variant) As Long
Dim position As Long
'default return value if value not found in array
IsInArray = -1
If IsArrayEmpty(Arr) Then Exit Function
For position = LBound(Arr) To UBound(Arr) 'subscript out of range
If Arr(position) = stringToBeFound Then
IsInArray = position + 1
Exit For
End If
Next
End Function
Public Function IsArrayEmpty(Arr As Variant) As Boolean
Dim LB As Long
Dim UB As Long
Err.Clear
On Error Resume Next
If IsArray(Arr) = False Then
IsArrayEmpty = True
End If
' Attempt to get the UBound of the array. If the array is unallocated, an error will occur.
UB = UBound(Arr, 1)
If (Err.Number <> 0) Then
IsArrayEmpty = True
Else
Err.Clear
LB = LBound(Arr)
If LB > UB Then
IsArrayEmpty = True
Else
IsArrayEmpty = False
End If
End If
End Function
Irgendwelche Ideen?
Danke für die Antwort positionieren . Offensichtlich war der beste Weg, dieses Problem anzugehen, die Variablen vor der Pasting-Schleife anzugeben. So läuft es, ohne übermäßig zu iterieren. Ich habe diesen neuen Teil des Codes als Antwort eingefügt. – DGMS89