スポンサーサイト

2023.04.20 Thursday
0

    一定期間更新がないため広告を表示しています

    category:- | by:スポンサードリンク | - | - | -

    vba3

    2013.05.29 Wednesday 06:46
    0
      vba 列ソート
      vba じゅうふく さくじょ
      xlTopToBottom 1 既定値。行方向の並べ替えになります
      xlLeftToRight 2 列方向の並べ替えになります


      [VBA]シートの重複データを削除する [VBA・VBS]
      Sub Macro1()
        Selection.CurrentRegion.Select
        Selection.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
      End Sub


      http://officetanaka.net/excel/vba/tips/tips14.htm

      http://note.chiebukuro.yahoo.co.jp/detail/n9077
      category:it | by:ittoocomments(0)trackbacks(0) | -

      vba2

      2013.05.27 Monday 07:15
      0
        Sub start()
        Dim strPath, strPath1, strLocalPath, strLocalBook As String
        Dim strBook, strBook1 As String
        Dim strGyou, strGyou1 As String
        Dim strReso, strReso1 As String
        Dim strSheet(20) As String
        Dim strKikan, strKikan1 As String
        Dim strOS, strChartMkbn, strChartClm As String
        Dim dblClm, dblClm1 As String
        Dim dblRow, dblRow1 As String
        Dim dblsetData(1441) As String
        Dim intRow As Integer
        Dim strObjName As String
        Dim strObj As Integer
        Dim i As Integer
        Dim result_copy As String
        Dim output_csv_filename As String
        Dim output_start_row2 As Integer

        '# 変数セット start
        ' ★エラーになるので一時 out しておぐ
        'With Application.FileDialog(msoFileDialogFolderPicker)
        '.Title = "日次リソースフォルダを選んでね"
        '.InitialFileName = "Sheet1.Cells(15,3)"
        'If .Show = True Then
        'strPath = .SelectedItem(1)
        'End If
        'End With
        strLocalPath = ActiveWorkbook.Path
        strLocalBook = ActiveWorkbook.Name
        strGyou = Sheet1.Cells(2, 3)
        strReso = Sheet1.Cells(3, 3)
        strOS = Sheet1.Cells(10, 3)
        strChartMkbn = Sheet1.Cells(11, 3)
        strChartClm = Sheet1.Cells(13, 3)
        If Sheet1.Cells(12, 3) = "折れ線" Then varChartType = 4
        If Sheet1.Cells(12, 3) = "" Then varChartType = 65
        If Sheet1.Cells(12, 3) = "" Then varChartType = 76
        intRow = 25


        '# 作業用シート
        a = 3
        Do Until Sheet1.Cells(4, a) = ""
        ' ★シートつぐっちゃうので 一時 out しておぐ
        strSheet(a) = Sheet1.Cells(4, a)
        '
        ' Sheets.Add After:=Sheets(Sheets.Count)
        ' ActiveSheet.Name = strSheet(a)
        '# output file あるなら delete
        If Dir(strLocalPath & "¥" & strSheet(a) & "_tmp.txt") <> "" Then
        Kill strLocalPath & "¥" & strSheet(a) & "_tmp.txt"
        End If
        ' MsgBox "a [" & a & "] strSheet(a)[" & strSheet(a) & "]"
        a = a + 1
        Loop
        dblClm = Sheet1.Cells(7, 3) '#
        dblClm1 = Sheet1.Cells(8, 3) '#
        '# 変数セット end




        '#===========================================
        '# main start
        '#===========================================
        '# a は 日がはいる 20130329 20130330 20130331
        For a = Sheet1.Cells(5, 3) To Sheet1.Cells(5, 4)
        strBook = strGyou & strReso & "_" & a & ".xls"
        strPath1 = "D:¥ファイル¥vba_macro¥" & strBook

        If Dir(strPath1) <> "" Then
        'MsgBox "1 strPath1 ファイルある " & strPath1
        Workbooks.Open Filename:=strPath1
        Else
        ' MsgBox "2 strPath1 ファイルない " & strPath1
        GoTo LABEL1
        End If

        b = 3

        '#プロパティで指定した シート分 loop strSheet(b)の値は、b★ct010 b★ct020 b★ct030
        Do Until strSheet(b) = ""
        ' MsgBox "0004 次のシートへ移動 a [" & a & "] b [" & b & "] strSheet(b)[" & strSheet(b) & "]"

        output_csv_filename = ActiveWorkbook.Path & "¥" & strSheet(b) & "_tmp.txt"
        '# openしたファイルが 初日の場合
        ' If a = Sheet1.Cells(5, 3) Then
        '範囲指定 一度にcopy
        dblRow2 = Sheets(strSheet(b)).Cells(2, 20).End(xlDown).Row
        input_start_row = 1
        output_sheet_name = "sheet2"
        sabun = dblRow2 - input_start_row
        '初日の場合はタイトル必要なので1行よりcopy。2日以降は、タイトルいらないので2行目より copy
        If a = Sheet1.Cells(5, 3) Then
        start_row = 1
        output_row_max = intRow
        Else
        start_row = 2
        ' MsgBox "1000c b[" & b & "] ThisWorkbook[" & ThisWorkbook.Name & "] ThisWorkbook.Sheets.Count[" & ThisWorkbook.Sheets.Count & "]" '# 5
        ' MsgBox "1000e ThisWorkbook.Sheets(strSheet(b))[" & ThisWorkbook.Sheets(strSheet(b)).Name & "]" '# エラープロシージャーでる
        output_row_max = ThisWorkbook.Sheets(strSheet(b)).Range("T" & intRow).End(xlDown).Row + 1 '# copy先の最大行番号 T列が時間
        End If
        Call line_copy(strBook, strSheet(b), start_row, dblRow2, ThisWorkbook.Name, strSheet(b), output_row_max, output_row_max + sabun, a, intRow)
        '# Clm サイド loop

        dblRow1 = Sheets(strSheet(b)).Cells(2, dblClm).End(xlDown).Row '# dblClm は時間
        'For d = dblClm To dblClm1
        'Sheets(strSheet(b)).Cells(2, d).Select
        'dblRow1 = Sheets(strSheet(b)).Cells(2, d).End(xlDown).Row
        'Set UsedCell = Sheets(strSheet(b)).UsedRange
        'Max_Row = UsedCell.Cells(UsedCell.Count).Row
        'Max_Column = UsedCell.Cells(UsedCell.Count).Column
        '# 時間のClm の最終行の値を採用する(抜げがないとして)
        'If d = dblClm Then
        ' time_last_row = dblRow1
        'End If
        ' c = 1
        'Next


        '# 日 整える
        Sheets(strSheet(b)).Row (20)

        '#/整える


        b = b + 1
        Loop
        LABEL1:
        Next
        MsgBox "main end"
        '# /main end


        '# グラフ
        Do Until strSheet(b) = ""
        Sheets(strSheet(b)).Selection.AutoFilter
        LABEL2:
        b = b + 1
        Loop
        '# /グラフ
        End Sub

        '#===========================================
        '# 行copy
        '#===========================================
        Function line_copy(input_file_name, input_sheet_name, input_start_row, input_end_row, _
        output_file_name, output_sheet_name, output_start_row, output_end_row, _
        resource_date, intRow)
        Workbooks(output_file_name).Sheets(output_sheet_name).Rows(output_start_row & ":" & output_end_row).Value = _
        Workbooks(input_file_name).Sheets(input_sheet_name).Rows(input_start_row & ":" & input_end_row).Value
        ' 初日
        If intRow = output_start_row Then
        output_start_row2 = output_start_row + 1
        output_end_row2 = output_end_row
        Else
        '2日より後
        output_start_row2 = output_start_row
        output_end_row2 = output_end_row - 1
        End If

        MsgBox resource_date

        '左に日にち入れる
        Workbooks(output_file_name).Sheets(output_sheet_name).Range(Cells(output_start_row2, 19), Cells(output_end_row2, 19)).Value = resource_date
        End Function





        category:- | by:ittoocomments(0)trackbacks(0) | -

        vba excel

        2013.05.27 Monday 00:01
        0
          Sub start()
          Dim strPath, strPath1, strLocalPath, strLocalBook As String
          Dim strBook, strBook1 As String
          Dim strGyou, strGyou1 As String
          Dim strReso, strReso1 As String
          Dim strSheet(20) As String
          Dim strKikan, strKikan1 As String
          Dim strOS, strChartMkbn, strChartClm As String
          Dim dblClm, dblClm1 As String
          Dim dblRow, dblRow1 As String
          Dim dblsetData(1441) As String
          Dim intRow As Integer
          Dim strObjName As String
          Dim strObj As Integer
          Dim i As Integer
          Dim result_copy As String


          '# 変数セット start
          ' ★エラーになるので一時 out しておぐ
          'With Application.FileDialog(msoFileDialogFolderPicker)
          '.Title = "日次リソースフォルダを選んでね"
          '.InitialFileName = "Sheet1.Cells(15,3)"
          'If .Show = True Then
          'strPath = .SelectedItem(1)
          'End If
          'End With
          strLocalPath = ActiveWorkbook.Path
          strLocalBook = ActiveWorkbook.Name
          strGyou = Sheet1.Cells(2, 3)
          strReso = Sheet1.Cells(3, 3)
          strOS = Sheet1.Cells(10, 3)
          strChartMkbn = Sheet1.Cells(11, 3)
          strChartClm = Sheet1.Cells(13, 3)
          If Sheet1.Cells(12, 3) = "折れ線" Then varChartType = 4
          If Sheet1.Cells(12, 3) = "" Then varChartType = 65
          If Sheet1.Cells(12, 3) = "" Then varChartType = 76
          intRow = 25


          '# 作業用シート
          a = 3
          Do Until Sheet1.Cells(4, a) = ""
          ' ★シートつぐっちゃうので 一時 out しておぐ
          strSheet(a) = Sheet1.Cells(4, a)
          '
          ' Sheets.Add After:=Sheets(Sheets.Count)
          ' ActiveSheet.Name = strSheet(a)
          '# output file あるなら delete
          If Dir(strLocalPath & "¥" & strSheet(a) & "_tmp.txt") <> "" Then
          Kill strLocalPath & "¥" & strSheet(a) & "_tmp.txt"
          End If
          ' MsgBox "a [" & a & "] strSheet(a)[" & strSheet(a) & "]"
          a = a + 1
          Loop
          dblClm = Sheet1.Cells(7, 3)
          dblClm1 = Sheet1.Cells(8, 3)
          '# 変数セット end




          '#===========================================
          '# main start
          '#===========================================
          '# a は 日がはいる 20130329 20130330 20130331
          For a = Sheet1.Cells(5, 3) To Sheet1.Cells(5, 4)
          strBook = strGyou & strReso & "_" & a & ".xls"
          strPath1 = "D:¥ファイルパス¥vba_macro¥" & strBook

          If Dir(strPath1) <> "" Then
          MsgBox "1 strPath1 ファイルある " & strPath1
          Workbooks.Open Filename:=strPath1
          Else
          ' MsgBox "2 strPath1 ファイルない " & strPath1
          GoTo LABEL1
          End If

          b = 3

          '#プロパティで指定した シート分 loop strSheet(b)の値は、b★ct010 b★ct020 b★ct030
          Do Until strSheet(b) = ""
          ' MsgBox "0004 次のシートへ移動 a [" & a & "] b [" & b & "] strSheet(b)[" & strSheet(b) & "]"
          Dim output_csv_filename As String
          output_csv_filename = ActiveWorkbook.Path & "¥" & strSheet(b) & "_tmp.txt"
          '# openしたファイルが 初日の場合
          ' If a = Sheet1.Cells(5, 3) Then
          '範囲指定 一度にcopy
          dblRow2 = Sheets(strSheet(b)).Cells(2, 20).End(xlDown).Row
          input_start_row = 1
          output_sheet_name = "sheet2"
          sabun = dblRow2 - input_start_row
          '初日の場合はタイトル必要なので1行よりcopy。2日以降は、タイトルいらないので2行目より copy
          If a = Sheet1.Cells(5, 3) Then
          start_row = 1
          output_row_max = intRow
          Else
          start_row = 2
          output_row_max = ThisWorkbook.Sheets(strSheet(b)).Range("T" & intRow).End(xlDown).Row + 1 '# copy先の最大行番号 T列が時間
          End If
          Call line_copy(strBook, strSheet(b), start_row, dblRow2, ThisWorkbook.Name, strSheet(b), output_row_max, output_row_max + sabun, a, intRow)
          '# Clm サイド loop
          For d = dblClm To dblClm1
          Sheets(strSheet(b)).Cells(2, d).Select
          dblRow1 = Sheets(strSheet(b)).Cells(2, d).End(xlDown).Row
          Set UsedCell = Sheets(strSheet(b)).UsedRange
          Max_Row = UsedCell.Cells(UsedCell.Count).Row
          Max_Column = UsedCell.Cells(UsedCell.Count).Column
          '# 時間のClm の最終行の値を採用する(抜げがないとして)
          If d = dblClm Then
          time_last_row = dblRow1
          End If
          c = 1
          Next
          b = b + 1
          Loop
          LABEL1:
          Next
          MsgBox "main end"
          '# /main end
          '# グラフ
          Do Until strSheet(b) = ""
          Sheets(strSheet(b)).Selection.AutoFilter
          LABEL2:
          b = b + 1
          Loop
          '# /グラフ
          End Sub

          '#===========================================
          '# 行copy
          '#===========================================
          Function line_copy(input_file_name, input_sheet_name, input_start_row, input_end_row, _
          output_file_name, output_sheet_name, output_start_row, output_end_row, _
          resource_date, intRow)
          Dim output_start_row2 As Integer
          Workbooks(output_file_name).Sheets(output_sheet_name).Rows(output_start_row & ":" & output_end_row).Value = _
          Workbooks(input_file_name).Sheets(input_sheet_name).Rows(input_start_row & ":" & input_end_row).Value
          ' 初日
          If intRow = output_start_row Then
          output_start_row2 = output_start_row + 1
          output_end_row2 = output_end_row
          Else
          '2日より後
          output_start_row2 = output_start_row
          output_end_row2 = output_end_row - 1
          End If
          '左に日にち入れる
          Workbooks(output_file_name).Sheets(output_sheet_name).Range(Cells(output_start_row2, 19), Cells(output_end_row2, 19)).Value = resource_date
          End Function

          category:- | by:ittoocomments(0)trackbacks(0) | -

          ソニー Xperia A SO-04Eのスマホカバーを買ったよ

          2013.05.21 Tuesday 22:36
          0
            ソニー Xperia A SO-04Eのスマホカバーを買ったよ。
            柔らかい手触りな、ソフトタイプのやつね。


            ドコモがキャンペーンで、
            サムスンのGALAXY S4 SC-04Eと、ソニーのXperia A SO-04Eの
            2機種を対象に最大24ヶ月で10800円安くなるという
            のをやっているそうなので、さっそくXperia A SO-04Eに
            機種変更してきた。
            前の機種もそうとう長い間つかってたしね。


            ドコモショップで2時間ほどかかってようやく
            Xperia A SO-04Eに変更。
            ちなみに色の一番人気の色はピンク。
            次に人気があったのは白でした。


            ちなみにドコモショップではXperia A SO-04Eの
            カバーは売り切れ状態だったので、PC-DEPTで購入。
            買ったのは、ハードタイプは嫌なので柔らかいこいつ。

            レイ・アウト docomo Xperia A SO-04E用 ソフトジャケット/マットクリア RT-SO04EC6/C
            レイ・アウト docomo Xperia A SO-04E用 ソフトジャケット/マットクリア RT-SO04EC6/C

            他の色もいいど、端末の白だしね。

            レイ・アウト docomo Xperia GX SO-04Dヨウ キラキラ・ ソフトジャケット/ラメブルー RT-SO04DC7/A
            レイ・アウト docomo Xperia GX SO-04Dヨウ キラキラ・ ソフトジャケット/ラメブルー RT-SO04DC7/A

            レイ・アウト docomo Xperia A SO-04E用 ソフトジャケット/マットブラック RT-SO04EC6/B
            レイ・アウト docomo Xperia A SO-04E用 ソフトジャケット/マットブラック RT-SO04EC6/B

            ちなみにハードなカバーが好きなひとはこっち。
            レイ・アウト docomo Xperia A SO-04E用 ハードコーティング・シェルジャケット/コーラルピンク RT-SO04EC3/P
            レイ・アウト docomo Xperia A SO-04E用 ハードコーティング・シェルジャケット/コーラルピンク RT-SO04EC3/P

            レイ・アウト docomo Xperia A SO-04E用 マットハードコーティング・シェルジャケット/マットブラック RT-SO04EC4/B
            レイ・アウト docomo Xperia A SO-04E用 マットハードコーティング・シェルジャケット/マットブラック RT-SO04EC4/B

            レザータイプもあるよ。
            レイ・アウト docomo Xperia A SO-04E用 フラップタイプ・レザージャケット(合皮タイプ)/ブラック RT-SO04ELC1/B
            レイ・アウト docomo Xperia A SO-04E用 フラップタイプ・レザージャケット(合皮タイプ)/ブラック RT-SO04ELC1/B


            最初は日本語入力できずにちょっととまどったけどね。
            ショップのお姉さんに聞くとソニーのXperia A SO-04Eが値下げ対象という
            ことで、かなりの人気のようでした。
            category:スマートフォン | by:ittoocomments(0)trackbacks(0) | -

            武蔵小山のマクドナルド3Fで無線lanにつながらない

            2013.05.11 Saturday 15:43
            0
              武蔵小山のマクドナルド にいるんだけど
              bbモバイルポイントの無線lanにつながらない。
              なんでだろ? 他のフロアでもそうなのか?と
              3F席から2F席に移ると
              無線lanに接続できた。

              1フロア移るだけでも、電波の状況って
              かなり違うのね。

              というか、武蔵小山マクドナルド店には
              3F席でも無線lanに接続できるようにしてほしいっす。

              category:無線lan | by:ittoocomments(0)trackbacks(0) | -

              ad
              Calender
                 1234
              567891011
              12131415161718
              19202122232425
              262728293031 
              << May 2013 >>
              Selected entry
              PR
              Category
              Archives
              Recommend
              Link
              Profile
              Search
              Others
              Mobile
              qrcode
              Powered
              無料ブログ作成サービス JUGEM