Попробуйте этот код, пожалуйста. Чего я не понял, так это того, как справиться с «Front Team», «Mid Team» и «Rear Team». Должны ли они быть написаны на каждой строке? Если да, это можно сделать, но массив должен заполняться строка за строкой, теряя некоторое время. Я не мог понять, почему, и код помещает их по одному разу в конце каждого диапазона листа ... Пожалуйста, уточните вашу потребность с этой точки view.
Private Sub CommandButton3_Click()
Dim Ws As Worksheet, lastRow As Long, lastCol As Long
Dim shExp As Worksheet, arrTransf As Variant
Set shExp = Worksheets.Add(After:=Worksheets(1))
shExp.Name = "Export_Sheet"
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "Contents Page" And Ws.Name <> "Completed" And _
Ws.Name <> "VBA_Data" And Ws.Name <> "Front Team Project List" And _
Ws.Name <> "Mid Team Project List" And Ws.Name <> _
"Rear Team Project List" And Ws.Name <> "Acronyms" Then
lastRow = Ws.Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Ws.UsedRange.Columns.Count
arrTransf = Ws.Range(Ws.Cells(6, 1), Ws.Cells(lastRow, lastCol)).value
shExp.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(arrTransf, 1), _
UBound(arrTransf, 2)).value = arrTransf
'this line replaces the last value in the column J:J, but so was the original code
shExp.Range("j" & Rows.Count).End(xlUp).value = Ws.Name
If Ws.Range("J1").value = "Front Team" Then _
shExp.Range("k" & Rows.Count).End(xlUp).Offset(1).value = "Front Team"
If Ws.Range("J1").value = "Mid Team" Then _
shExp.Range("k" & Rows.Count).End(xlUp).Offset(1).value = "Mid Team"
If Ws.Range("J1").value = "Rear Team" Then _
shExp.Range("k" & Rows.Count).End(xlUp).Offset(1).value = "Rear Team"
End If
Next
End Sub
Edited: второй код, который касается вставки другой строки после каждого сохранения данных. Пожалуйста, проверьте это и подтвердите, что это то, что вы хотели. Особенно, что касается позиции названия листа ...
Private Sub CommandButton3_Click()
Dim Ws As Worksheet, lastRow As Long, lastCol As Long, k As Long, i As Long
Dim shExp As Worksheet, arrTransf As Variant, arrFin As Variant, m As Long
Set shExp = Worksheets.Add(After:=Worksheets(1))
shExp.Name = "Export_Sheet"
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "Contents Page" And Ws.Name <> "Completed" And _
Ws.Name <> "VBA_Data" And Ws.Name <> "Front Team Project List" And _
Ws.Name <> "Mid Team Project List" And Ws.Name <> _
"Rear Team Project List" And Ws.Name <> "Acronyms" Then
lastRow = Ws.Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Ws.UsedRange.Columns.Count
arrTransf = Ws.Range(Ws.Cells(6, 1), Ws.Cells(lastRow, lastCol)).value
ReDim arrFin(1 To UBound(arrTransf, 2), 1 To UBound(arrTransf, 1) * 4)
For i = 1 To UBound(arrTransf, 1)
For m = 1 To UBound(arrTransf, 2)
arrFin(m, i + IIf(m > 11, k - 1, k)) = arrTransf(i, m)
If m = 10 Then arrFin(10, i + k) = Ws.Name
'If you would need the sheet name on the same row with "xxx Team, replace the above line with the next one. In fact uncomment it and delete the above one:
'If m = 10 Then arrFin(10, i + k + 1) = Ws.Name
If m = 11 Then
If Ws.Range("J1").value = "Front Team" Then
arrFin(11, i + k + 1) = "Front Team": k = k + 1
ElseIf Ws.Range("J1").value = "Mid Team" Then
arrFin(11, i + k + 1) = "Mid Team": k = k + 1
ElseIf Ws.Range("J1").value = "Rear Team" Then
arrFin(11, i + k + 1) = "Rear Team": k = k + 1
End If
End If
Next m
Next i
ReDim Preserve arrFin(1 To UBound(arrTransf, 2), i + k - 2)
shExp.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(arrFin, 2), _
UBound(arrFin, 1)).value = WorksheetFunction.Transpose(arrFin)
End If
Next
End Sub