Sub dimenticaMe()
Const strG As String = "G8:G8,G10:G10,G12:G12,G14:G14,G16:G16,G21:G21,G23:G23,G25:G25,G30:G30,G32:G32,G80:G80,G81:G81,G82:G82,G83:G83,G84:G84,G85:G85,G86:G86,G87:G87"
Dim oDlg As FileDialog, V
Dim oWbData As Excel.Workbook
Dim oWsData As Excel.Worksheet, oSoleMio As Excel.Worksheet
Dim rngTo As Range
Dim arrCells() As String, x As Long
Dim bln As Boolean: bln = Application.ScreenUpdating
Application.ScreenUpdating = False
Set oSoleMio = ThisWorkbook.Sheets(1)
With oSoleMio
Set rngTo = .Cells(1, .Columns.Count).End(xlToLeft).EntireColumn
If rngTo.Cells(1).Value <> "" Then Set rngTo = rngTo.Offset(, 1).EntireColumn
End With
arrCells = Split(strG, ",")
Set oDlg = Application.FileDialog(msoFileDialogOpen)
With oDlg
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Excel-Datei(en)", "*.xls?"
.Show
For Each V In .SelectedItems
Set oWbData = Workbooks.Open(V)
With oWbData
rngTo.Cells(1).Value = oWbData.Name & "_G"
rngTo.Offset(, 1).Cells(1).Value = "_T"
For Each oWsData In oWbData.Sheets
For x = LBound(arrCells) To UBound(arrCells)
If oWsData.Range(arrCells(x)).Value <> "" Then
oWsData.Range(arrCells(x)).Copy rngTo.Cells(rngTo.Cells.Count).End(xlUp).Offset(1)
oWsData.Range(arrCells(x)).Offset(, 13).Copy rngTo.Cells(rngTo.Cells.Count).End(xlUp).Offset(, 1)
End If
Next x
Next oWsData
.Close False
Set rngTo = rngTo.Offset(, 2)
End With
Next V
End With
oSoleMio.Columns.AutoFit
On Error GoTo 0
fail:
Application.ScreenUpdating = bln
End Sub