複数シートから条件に合ったデータを抽出して、別シー

質問

複数シートから条件に合ったデータを抽出して、
別シートにそれぞれコピーしたいのです。

自分なりに本やネットを見て、切貼りで作成したのですが、
全く動作しないのです。マクロ超初心者です。

どなたか新しいVBAもしくは、変更VBAを教えて頂けるとうれしいです。

やりたいことは
一つのBOOK内の複数シート(別表1,2,原本,データのシート以外)から
条件に合うデータを
AA列にあるデータ(△,▼)をそれぞれ抽出して、別々のシート(Upgrade、Downgrade)に見出し行より下から
順番(見出行が12行まで)にコピー貼付けした後(書式などがあるので、すべて貼付け)
数式が入ってるので、最後に全体をコピーして値の貼付けをしたいです。

複数シートは基本的に同じですが、稀に列がずれて貼付くことがあるので、
列見出しと同じ場所に貼付けるように設定したいです。

エクセル2003です。

何卒、宜しくお願いいたしますm(__)m

一応、全く使えませんがVBAを貼り付けておきます。

Sub データ更新()

Dim U As Worksheet
Dim D As Worksheet
Dim 行 As Integer
Dim 列 As Integer
Dim S As Integer
Dim A As String
Dim B As String
Dim C As Range

'コピー先シート名
U.Name = Upgrade
D.Name = Downgrade

行 = 13 '開始行
列 = AA '検索列
S = cell(13, 1) '開始セル

'検索文字
A = "△"
B = "▼"

'古いデータ削除
Do Until Sheets(U).Cells(行, A) = ""
Cells ClearContents

行 = 行 + 1
Sheets(U).Activate

行 = 13

'シートループ処理

For Each U In Worksheets

'除くシート
If U.Name <> "別表1" And U.Name <> "別表2" And U.Name <> "データ" And U.Name <> "原本" Then

'抽出コピー
For 行 = 13 To Range("bD200").End(xlToLeft).Column

If Range("AA").Value = A Then
If S Is Nothing Then
Exit Sub

Do Until cell(行, 1) = ""
Range(S).CurrentRegion.AdvancedFilter xlFilterCopy, Range("200:56"), Sheets(Cells(S).Text).Range("a13")

行 = 行 + 1

'列名から貼付ける列番号を返す
For Each C In convinedseet.Rows(1).Cells
If CStr(C.Value) = FieldName Then
ColumnNumber = C.Column
Exit For

elself CStr(C.Value) = ""
C.Value = FieldName
ColumnNumber = C.Column
Exit For

Loop

End If
End If
End If
Next

End Sub

回答No.1

K Kazz（@JazzCorp）

'そのポン骨よりは少しだけ働くかも、、、
'ネタをアクティブにして実行する
'環境に依存するところ（Const）は適当に変更する
Option Explicit
Sub ぶんるいふぁくとりぃ()
Const xHop = "その１"
Const xStep = "その2"
Const xJump = "その3"
Const xUpUp = "△"
Const xDown = "▼"
Const xKey_Col = 1
Const xHeads = 1
Dim xSheet As Worksheet
Dim xTarget As Variant
Dim xLast As Long
Dim xLast_To As Long
Dim kk As Long
Dim nn As Long
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(xHop).Delete
Worksheets(xStep).Delete
Worksheets(xJump).Delete
Set xSheet = ActiveSheet
xLast = Cells(Rows.Count, xKey_Col).End(xlUp).Row
If (xLast > xHeads) Then
For nn = xHeads + 1 To xLast
Select Case (xSheet.Cells(nn, xKey_Col).Value)
Case xUpUp
xTarget = xHop
Case xDown
xTarget = xStep
Case Else
xTarget = ""
End Select
If (xTarget <> "") Then
kk = Worksheets.Count
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = xTarget
If (Worksheets.Count > kk) And (Worksheets(Worksheets.Count).Name <> xTarget) Then
Worksheets(Worksheets.Count).Delete
End If
With Worksheets(xTarget)
xLast_To = .Cells(Rows.Count, xKey_Col).End(xlUp).Row
If (xLast_To = 1) And IsEmpty(.Range("A1")) Then
Application.CutCopyMode = False
xSheet.Rows("1:" & xHeads).Copy
.Rows(1).Resize(xHeads).PasteSpecial
End If
Application.CutCopyMode = False
xSheet.Rows(nn).Copy
'.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'.PasteSpecial Paste:=xlPasteFormats
xLast_To = .Cells(Rows.Count, xKey_Col).End(xlUp).Row
.Rows(xLast_To).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
End If
Next
Else
MsgBox ("No Data Found!!")
End If
Worksheets(1).Select
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

補足

JazzCorpさん

ありがとうございます。

折角 新しくコードを書いてくださったのに、
残念ながら
エラーは出ませんが、命令がスルーしてしまい　集計シートには何の変化も無くて
コピーも作成されないんです。

どうしてかしら？？

すごく　すごく残念です。

シートはコピーする順番に左から並んでいます。(集計シートを間に挟んで)左がコピーしたいシート
右が参考資料など、コピーから除外したいシートが並んでいます。

一応、集計シートをアクティブにして、マクロを実行してます。