Sub tanaorosi()
 --- 略　---
Do
    Num = ws.Cells(RowPos, ColPos + 1)
    If Num = "梱包" Then
        ws.Cells(RowPos, ColPos - 9).Copy
        ws2.Cells(RowPos, ColPos - 9).PasteSpecial Paste:=xlPasteValues
    End If
    RowPos = RowPos + 1
Loop While Num <> "end"
--- 略　---
End Sub

Sub tanaorosi()
 --- 略　---
    Selection.SpecialCells(xlCellTypeLastCell).Select
    endr = ActiveCell.Row
For RowPos = 5 To endr
       Num = ws.Cells(RowPos, ColPos + 1)
        If Num = "梱包" Then
            ws.Cells(RowPos, ColPos - 9).Copy
            ws2.Cells(RowPos, ColPos - 9).PasteSpecial Paste:=xlPasteValues
        End If
Next
--- 略　---
End Sub
　---------------------------------------
上記に変更後、プログレスバーで表示を追加しました。なお、自分の作成した
Forステートメントの中にマクロを追加する件が判りずらいようなので、今回
下記のように分割しました。自分の作成したマクロに、Call puro1・・Call puro4
を追加すればよい。（追加個所は下記参照のこと）

Dim i As Integer
Dim j As Integer
Dim endr As Integer
Dim tsiz As Integer
Sub tanaorosi()
 --- 略　---
Call puro1
For RowPos = 5 To endr
i = RowPos
Call puro2
       Num = ws.Cells(RowPos, ColPos + 1)
        If Num = "梱包" Then
            ws.Cells(RowPos, ColPos - 9).Copy
            ws2.Cells(RowPos, ColPos - 9).PasteSpecial Paste:=xlPasteValues
        End If
Call puro3   
Next
Call puro4
--- 略　---
End Sub
'-----------------------------
Sub puro1()
'ダイアログへ表示
With UserForm1
    .Caption = "マクロ実行中：しばらくお待ち下さい"
    .Label1.BackColor = RGB(255, 255, 0)
    .Label2.TextAlign = fmTextAlignCenter
    .Label2.BackStyle = 0
    .Label1.Width = 0
    tsiz = .Label2.Width
End With
UserForm1.Show vbModeless
End Sub
'-----------------------------
Sub puro2()
'進行計算
    j = i / endr * 100
    With UserForm1
        .Label2.Caption = Int(j) & "%"
        .Label1.Width = tsiz * j / 100
    End With
End Sub
'-----------------------------
Sub puro3()
'プログレス表示
   DoEvents
End Sub
'-----------------------------
Sub puro4()
'ダイアログを閉じる
  Unload UserForm1
End Sub
'-----------------------------

Sub Macro1()
    UserForm1.Show
End Sub
Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   UserForm1.TextBox1.Text = Format(UserForm1.TextBox1.Text, "yyyy/m/d")
End Sub

'------------------------------------------------------------
Sub Macro2()
    UserForm1.Show
    ddd = Range("A1").Value
    UserForm1.TextBox1.Value = Format(ddd, "yyyy/m/d")
End Sub

[2001/02/23 M.Tさんからの質問]
初めてお便りします。 私はVBAを始めた５４歳の初心者です。VBAマクロ500連発を 参考にして勉強しています。 非常に初歩的な質問で申し訳ないのですが、 是非教えて下さい。

number171"オートフィルターの抽出結果を追加した シートに貼り付ける"に関しての質問です。 小生のデータベースには、受注日列　2001/04/01と 納期列　２００１年４月10日と二つの検索したい列が あります。顧客番号とか顧客名とかでは、スムーズに 動作してくれるのですが、この２列の検索は上手く いきません。 原因は日付の文字列と、入力した数値が検索で 一致しないからだと思います。 試した事は
[1]textbox1に、かなで２００１年４月１０日と入力。
[2]々　　　　　、かなで2001/04/10。
[3]Textbox1.Value=Format(Textbox1.Value,"yyyy/mm/dd")
[4]intyear=(CDate(Userform1.Textbox1.Text))
month,dayも同様にして
　Textbox1Text＝intyear & "年”　＆　intmonth & "月".......
[5]"yyyy""年""mm""月""dd""日"""
と代入してもいずれも敗退しました。

成功したのは、 この２列のセル書式を標準にして、シリアル値に変換 すれば、シリアル値でオートフィルターは可能なのですが、 テキストボックスにシリアル値を入れるのは難しいです。 テキストボックスには、出来れば04/01、駄目ならば 2001/04/01といった日付入力をして検索したいのです。 値の一致のさせ方を教えて下さい。ここで詰まって３日目 なのでお助け下さい。
------------------------------------------------------------
先週下記のような質問があり、29-73へ掲載しました同じ内容ですがここにも掲載します。
「ユーザーフォーム上にふたつのテキストボックスがあり、 それぞれ、シート１のＡ列とＢ列に入っているデータを記入し、 コマンドボタンを押すと、そこから検索して、Ｃ列のデータを探して、 ユーザーフォーム上のラベル１に表示させたいのですが、どのように すればよろしいのでしょうか？」

---

上図のようにダイアロルへ入力すると、左図のように表示するマクロの作り方を 説明します。

[1] aaa()実行でダイアログを表示
[2] 「検索」ボタンクリックでaaa1()実行


---------------------------------------------------------
ポイント1．オ-トフィルタはセルに表示されている形式と合わないと抽出できません。 したがって下記のように入力したデータをセル表示に合わせる。

UserForm1.TextBox1.Text = Format(UserForm1.TextBox1.Text, "m""月""d""日""")
---------------------------------------------------------
ポイント2．下記セルの表示が[1][2][3]は問題なし。[4][5][6]は手で「データ」「フィルタ」 「オートフィルタ」で行なった場合は問題ないが、何故かマクロでは抽出できない、 何故ダメなのか判らないがExcel95の時からずーと同じです。Excel2000で改善されること を期待したいたがダメだった。しょうがないので[3]の年２桁で行なって下さい、 もしそれも問題がある場合は再度メールを下さい

[1]Format(UserForm1.TextBox1.Text, "m""月""d""日""") セル表示：1月2日　可
[2]Format(UserForm1.TextBox1.Text, "m/d") 　　　　　セル表示：1/2 可
[3]Format(UserForm1.TextBox1.Text, "yy/m/d")　　　　セル表示：01/1/2 可

[4]Format(UserForm1.TextBox1.Text, "ge.m.d")　セル表示：H13.1.2 不可
[5]Format(UserForm1.TextBox1.Text, "yy/m/d")　セル表示：2001/1/2 不可
[6]Format(UserForm1.TextBox1.Text, "ggge""年""m""月""d""日""")セル表示：平成13年1月2日　不可

Sub aaa()
UserForm1.Show
End Sub

Sub aaa1()
dat = ""

UserForm1.TextBox1.Text = Format(UserForm1.TextBox1.Text, "m""月""d""日""")

hizuke = UserForm1.TextBox1.Text
meigara = UserForm1.TextBox2.Text
'フィルタ
Range("A3").Select
Selection.AutoFilter
    Selection.AutoFilter Field:=2, Criteria1:=hizuke, Operator:=xlAnd
    Selection.AutoFilter Field:=3, Criteria1:=meigara, Operator:=xlAnd
    
'C列データ取得
  Range("a4").CurrentRegion.SpecialCells(xlVisible).Select
   For Each sel In Selection
        r = sel.Row
        If r <> 2 Then
            dat = Cells(r, 4)
            Exit For
        End If
   Next sel
If dat = "" Then
   dat = "抽出条件のデータなし"
End If
UserForm1.Label1.Caption = dat
Range("A2").Select
'フィルタ戻す
Selection.AutoFilter
End Sub

Dim meigara As Date
Sub Macro1()
  ActiveCell.SpecialCells(xlLastCell).Select
  endr = ActiveCell.Row
  Range(Cells(2, 2), Cells(endr, 2)).Select
  
  hizuke = UserForm1.TextBox1.Text
  
  For Each sel In Selection
        If sel.Value = hizuke Then
            sel.Select
            selr = ActiveCell.Row
            MsgBox "対象のセルは「" & selr & "「にあります"
        End If
    Next sel
Range("A1").Select
End Sub

[1].Formatでカンマを付ける
UserForm1.TextBox1.Text = Format(UserForm1.TextBox1.Text, "#,###")
kanma = UserForm1.TextBox1.Text

[2].桁数をチェックしカンマを付ける
kanma = UserForm1.TextBox1.Text
    aas = Len(kanma)
    If aas > 6 Then
            s1 = Right(kanma, 3)
            s2 = Mid(kanma, 1, aas - 3)
            s2 = Right(s2, 3)
            s3 = Mid(kanma, 1, aas - 6)
            kanma = s3 & "," & s2 & "," & s1
    ElseIf aas > 3 Then
            s1 = Right(kanma, 3)
            s2 = Mid(kanma, 1, aas - 3)
         kanma = s2 & "," & s1
    End If

[2001/03/09 U.Cさんからの質問]
ExcelＶＢＡマクロ５００連発第2弾各パーツについている「実行ボタン」について、 おせわになります各パーツを実行するための「実行」ボタン、右クリックしてもプロパテイと コードの表示がでません どのようにしたらよいでしょうか ちなみに隣に自分でコマンドボタンを作成したものは表示されます パソコンへは、「ＸＬＳＩＮＳＴ.ｅｘｅ」でインストールしました この本の内容をぜひとも理解したいと思い読んでおります。
上図の左図はメニューの[表示][ツールバー][フォーム]で描いたものです。
右図はメニューの[表示][ツールバー][コントロールツールボックス]で描いたもの。

※　ワ−クシ−トにコマンドボタンを表示しそれをクリックしてマクロを実行させる事が よくあるが、15.5KBのExcelファイルにActiveXコントロ−ル（上図の右図）の コマンドボタンを貼り付けクリックイベントで実行する場合は25.5KBの容量になった。 それに比べフォ−ム(OLEカスタムコントロ−ル：上図の左図)のコマンドボタンを 使用した場合は16.0KBで 0.5KB増えただけである。単純にあるマクロを実行させる だけであれば、私の場合フォ−ム(上図の左図)のコマンドボタンを使用している。

質問と回答が合っているかどうか不明ですが返事は以上です。

下記のように、検索文字の後ろに"*"を追加すればＯＫのはずです。

'あいまい検索
    dat1 = dat1 & "*"
    dat2 = dat2 & "*"
    dat = dat & "*"
'デ−タ検索
      Application.Worksheets(sname).Activate
      Range("a1").Select
      ------(略）

上記で問題がある場合は再度メールを下さい。

下記のdate1+10 を　date1+30　に変更すれば先30日の日付けが設定されます。
なお、実際は月により、28日・30日・31日と変わる為厳密には30日が一ヶ月と
言い切れませんが、一般的には30日を指定で問題ないと思います。

If Cells(50, 1) = "" Then
	Rows("50:50").RowHeight = 0
        Cells(50, 1) = date1 + 10
        ActiveSheet.Protect password:="0000"
        ActiveWorkbook.Save
        date2 = date1 + 10
        MsgBox "有効期限「" & date2 & "」となっています"
        kigen = 1
Else

下記例では、セル"A1"に2001/10/17が入っている場合セル"B1は、
Macro1　→　水曜日
Macro2　→　水曜日
Macro3　→　水
と表示されます。

Sub Macro1()
Dim week As Variant
week = Array("日", "月", "火", "水", "木", "金", "土")
    If IsDate(Cells(1, 1)) Then
        hi = CDate(Cells(1, 1))
        w = Weekday(hi)
        Cells(1, 2) = week(w - 1) & "曜日"
    End If
End Sub

Sub Macro2()
    hi = CDate(Cells(1, 1))
    Cells(1, 2) = Format(hi, "aaaa")
End Sub

Sub Macro3()
    hi = CDate(Cells(1, 1))
    Cells(1, 2) = Format(hi, "aaa")
End Sub

追記：
私がサポートするのは自分が掲載したサンプルマクロであって、
VBA全般の質問に対して回答すると言う意味ではありません。
誤解のないようお願いします。
次回質問の場合は掲載の番号付きでお願いします。

例1、例2のWorkbook_Open()はThisWorkbookをクリックして記述
例2のMacro1()、例3AUTO_OPEN()は標準モジュールへ記述

---------例1-------------------
Private Sub Workbook_Open()
mozi = Application.InputBox(msg, "題名", Type:=2)
End Sub

---------例2-------------------

Private Sub Workbook_Open()
Macro2
End Sub
Sub Macro1()
mozi = Application.InputBox(msg, "題名", Type:=2)
End Sub

---------例3-------------------
Sub AUTO_OPEN()
mozi = Application.InputBox(msg, "題名", Type:=2)
End Sub

--------------- 誤　-------------------
'月/日記入。
    For i = 1 To hisu

'曜日記入
    Range(Cells(2, cm), Cells(2, hisu)).Select

'日曜日色づけ
For i = cm To hisu

--------------- 正　-------------------
'月/日記入。
    For i = 1 To hisu - 1
  
'曜日記入
    Range(Cells(2, cm), Cells(2, hisu + cm)).Select

'日曜日色づけ
For i = cm To hisu + cm