人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

-18

エクセルのVBAについて質問です。

現在データの閲覧をしやすいようにしたいと考えております。

行いたいことですが、基のデータ(シート1)を条件判定ごとにSheet2、Sheet3、Sheet4とに分けるやり方です。

行いたいプログラムを実行する環境ですが以下になっております。

http://oskuni7.sakura.ne.jp/hatena//question18/question18.htm

今回ですがSheet2のデータが変更された場合、それに応じて元データのSheet1のデータの値が変更するようにしたいと考えております。

またSheet2の条件判定を変えるとSheet3やSheet4にデータが移動するということも行いたいです。

上記のようなプログラムを時間があるかたで作成していただけるかたおりましたら作成していただけないでしょうか?

またエクセルの横列を増やしていくうちに

データの消失を防ぐため、空白でないセルをワークシートの外にシフトすることはできません。

というエラーが出てきます。

エクセルのデータ保存の機能を拡張する方法などはないでしょうか?

いずれか知っているかたおりましたら、

お手数をおかけしますがどうぞよろしくお願いいたします。

●質問者: aiomock
●カテゴリ:コンピュータ インターネット
✍キーワード:VBA いるか エクセル エラー シフト
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● SALINGER
●60ポイント ベストアンサー

とりあえずシートに分けるマクロは作ってみました。

まず、各シートは4行目からデータが入っているとして、

図のようにSheet1の1行目の作業1とか作業2というのはマージされたセルとします。

ここから作業の数を数えて自動的に作業1とか作業2という名前のシートを作りデータをコピーします。

コピーする列は図ならば作業1がBL列?EO列までという感じです。


>★Sheet2,3,4のデータの判定(列AV)を変更した場合、データの移動が行われます。

この機能は実装しませんでした。この機能を実装することにより、かなりのオーバーヘッドが発生し

処理が重くなると思われます。面倒でもマクロを一回一回実行させたほうがいいと思われます。


Option Explicit

Type Sagyou
 name As String
 start As Integer
 end As Integer
 count As Long
End Type

Sub SheetWake()
 Application.ScreenUpdating = False
 Dim i As Integer
 Dim j As Integer
 Dim k As Integer
 Dim s() As Sagyou
 Dim f As Boolean
 ReDim s(0)
 Dim sh As Worksheet
 Dim lastRow As Long
 Dim r As Range
 
  '作業データの取得
 j = 1
 For i = 63 To 255
 If Sheet1.Cells(1, i).MergeCells Then
 If Not f Then
 ReDim Preserve s(UBound(s) + 1)
 s(UBound(s)).name = Sheet1.Cells(1, i).Value
 s(UBound(s)).start = i
 f = True
 End If
 s(UBound(s)).end = i
 Else
 f = False
 End If
 Next i
 
  'シートの追加
 For i = 1 To UBound(s)
 f = False
 For Each sh In Worksheets
 If sh.name = s(i).name Then
 Sheet1.Range(Cells(1, s(i).start), Cells(3, s(i).end)).Copy sh.Range("A1")
 f = True
 Exit For
 End If
 Next
 If Not f Then
 Set sh = Worksheets.Add
 sh.name = s(i).name
 Sheet1.Activate
 Sheet1.Range(Cells(1, s(i).start), Cells(3, s(i).end)).Copy sh.Range("A1")
 End If
 Next i
 
  '数式の除去
 For Each r In Sheet1.UsedRange
 If r.Row > 3 Then
 r.Value = r.Value
 End If
 Next
 
  'シートのクリア
 For Each sh In Worksheets
 If sh.name <> "Sheet1" Then
 sh.Rows("4:65536").ClearContents
 End If
 Next
 
  'データの移動
 lastRow = Sheet1.UsedRange.Rows(Sheet1.UsedRange.Rows.count).Row
 For i = 4 To lastRow
 f = False
 For j = 1 To UBound(s)
 If Sheet1.Cells(i, "AV").Value = s(j).name Then
 f = True
 Exit For
 End If
 Next
 If f Then
 Set sh = Worksheets(Sheet1.Cells(i, "AV").Value)
 sh.Cells(s(j).count + 4, 1).Value = s(j).name
 Sheet1.Cells(i, "AV").Formula = "=" & s(j).name & "!A" & s(j).count + 4
 For k = 1 To s(j).end - s(j).start
 sh.Cells(s(j).count + 4, k + 1).Value = Sheet1.Cells(i, s(j).start + k).Value
 Sheet1.Cells(i, s(j).start + k).Formula = "=" & s(j).name & "!" & sh.Cells(s(j).count + 4, k + 1).Address
 Next
 s(j).count = s(j).count + 1
 End If
 Next i
 Application.ScreenUpdating = True
End Sub
◎質問者からの返答

ご回答有難うございます。

試してみます。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ