Взываю к помощи, потому как знаний нехватает!
Предлагаю код, в примечаниях написал где у меня не получается:
Sub Создание()
'
Sheets("Список товара").Select
Application.DisplayAlerts = False
' !проверяет, если ячейка Q3 <>0, то копирует значения из диапазона Q3:AD3 в Q1:AD1
' !затем надо чтобы проверял значение в Q4 и копировал в Q1:AD1, и т.д.
x = 3
Do While Cells(x, 17).Value <> 0
Range("x,17 : x,30").Select
Selection.Copy
Range("Q1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' !это неработает надо исправлять
Sheets("Список товара").Select
Sheets("Лист1").Select
' !надо заставить фильтровать по значению из ячейки "А1"
ActiveSheet.Range("$B$1:$N$872").AutoFilter Field:=1, Criteria1:= _
("A1"), Operator:=xlAnd
Range("D2:D873").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Список товара").Select
Range("B3").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Sheets("Лист1").Select
Application.CutCopyMode = False
Selection.Copy
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Sheets("Список товара").Select
Range("B3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Бланк отчёта").Select
Range("B9:C9").Select
Sheets("Бланк отчёта").Select
Application.CutCopyMode = False
Sheets("Бланк отчёта").Copy
Dim strDate As String
strDate = Range("A1")
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\my\Desktop\" + strDate + ".xls", FileFormat:=xlExcel8, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
iLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(iLinks) Then
For i = LBound(iLinks) To UBound(iLinks)
ActiveWorkbook.BreakLink Name:=iLinks(i), Type:=xlExcelLinks
Next i
End If
ActiveWorkbook.Save
ActiveWindow.Close
Sheets("Список товара").Select
x = x + 1
Loop
Application.DisplayAlerts = True
End Sub