Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


17228 / 76738 ←次へ | 前へ→

【64967】Re:一覧表のデータを別シートに転記したい。
回答  Hirofumi  - 10/3/30(火) 22:01 -

引用なし
パスワード
   こんなのでは?

追加されたデータだけ転記するのは、追加分と前回分を分けるのが面倒なので
常に一覧表の先頭から振り分ける様にして有ります
依頼職場シートが無い場合は追加され、
有った場合は、コードが実行される度にクリアされ使い回されます

一覧表には、列見出しが有る物とします
データは、A列〜BM列の65列とし、転記するグループは、B列に有るとします
作業列としてBN列を使用します
実行時にB列で整列され終了直前に元の行位置に再整列されます

Option Explicit

Public Sub Sample_1()

  '元々のデータ列数(A列〜BM列)
  Const clngColumns As Long = 65
  'グループの有る列(B列のA列からの列Offset)
  Const clngGroup As Long = 1
  '結果出力の先頭位置
  Const cstrTop As String = "A7"
  
  Dim i As Long
  Dim lngRows As Long
  Dim lngTop As Long
  Dim lngCount As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntGroup As Variant
  Dim strProm As String

  'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = Worksheets("一覧表").Range("A7")

  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngGroup).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '復帰用整列Keyを作成
    With .Offset(1, clngColumns)
      .Value = 1
      .Resize(lngRows).DataSeries _
          Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
          Step:=1, Trend:=False
    End With
    'データをA列で整列
    DataSort .Offset(1).Resize(lngRows, clngColumns + 1), .Offset(, clngGroup)
    'A列データを配列に取得
    vntGroup = .Offset(1, clngGroup).Resize(lngRows + 1).Value
  End With
  
  '仮に結果と元表を同じにして置く
  Set rngResult = rngList
  '注目値の位置を記録
  lngTop = 1
  'データ行数のカウント初期値
  lngCount = 1
  For i = 2 To lngRows + 1
    '注目値と現在値が違った場合
    If vntGroup(lngTop, 1) <> vntGroup(i, 1) Then
      'シート名の存在確認をして、無い場合追加し在る場合はデータ消去
      GetSheets "依頼職場_" & vntGroup(lngTop, 1), cstrTop, rngResult
      With rngList
        '列見出しを転記
'        .Offset(, 2).Resize(, clngColumns).Copy Destination:=rngResult
        'データを転記
        .Offset(lngTop, 2).Resize(lngCount, clngColumns).Copy _
            Destination:=rngResult.Offset(1)
      End With
      '注目値の位置を記録
      lngTop = i
      'データ行数のカウント初期値に
      lngCount = 1
    Else
      'データ行数のカウントを更新
      lngCount = lngCount + 1
    End If
  Next i

  With rngList
    '元データを復帰
    DataSort .Offset(1).Resize(lngRows, clngColumns + 1), .Offset(1, clngColumns)
    '復帰用Key列を削除
    .Offset(, clngColumns).EntireColumn.Delete
  End With
   
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
   
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngSortOrder As Long = xlAscending, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=lngSortOrder, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

Private Sub GetSheets(vntName As Variant, strTop As String, rngResult As Range)
  
  Dim i As Long
  Dim lngRows As Long
  Dim wksMark As Worksheet
  
  'シートの存在確認
  For Each wksMark In Worksheets
    If StrComp(wksMark.Name, vntName, vbTextCompare) = 0 Then
      Exit For
    End If
  Next wksMark
  'もし、シートが無いなら
  If wksMark Is Nothing Then
    'シートを追加して、シート名を設定
    Set wksMark = Worksheets.Add(After:=rngResult.Parent)
    wksMark.Name = vntName
  Else
    'データを消去
    wksMark.UsedRange.ClearComments
  End If
  
  Set rngResult = wksMark.Range(strTop)
  
  Set wksMark = Nothing
  
End Sub
0 hits

【64966】一覧表のデータを別シートに転記したい。 AAA 10/3/30(火) 21:20 質問
【64967】Re:一覧表のデータを別シートに転記したい。 Hirofumi 10/3/30(火) 22:01 回答
【64972】一覧表のデータを別シートに転記したい。 AAA 10/3/31(水) 13:10 質問
【64973】Re:一覧表のデータを別シートに転記したい。 Hirofumi 10/3/31(水) 14:04 回答
【64974】Re:一覧表のデータを別シートに転記したい。 Hirofumi 10/3/31(水) 14:25 発言
【64975】一覧表のデータを別シートに転記したい。 AAA 10/3/31(水) 14:42 質問
【64976】Re:一覧表のデータを別シートに転記したい。 Hirofumi 10/3/31(水) 15:00 回答
【64977】Re:一覧表のデータを別シートに転記したい。 AAA 10/3/31(水) 15:04 質問
【64978】Re:一覧表のデータを別シートに転記したい。 Hirofumi 10/3/31(水) 15:08 回答
【64979】Re:一覧表のデータを別シートに転記したい。 AAA 10/3/31(水) 15:17 質問
【64980】Re:一覧表のデータを別シートに転記したい。 Hirofumi 10/3/31(水) 15:33 回答
【64982】一覧表のデータを別シートに転記したい。 AAA 10/3/31(水) 15:59 質問
【64983】Re:一覧表のデータを別シートに転記したい。 Hirofumi 10/3/31(水) 16:17 回答
【64984】一覧表のデータを別シートに転記したい。 AAA 10/3/31(水) 16:33 質問
【64986】Re:一覧表のデータを別シートに転記したい。 Hirofumi 10/3/31(水) 17:31 回答
【64992】Re:一覧表のデータを別シートに転記したい。 AAA 10/3/31(水) 20:26 お礼
【64993】Re:一覧表のデータを別シートに転記したい。 Hirofumi 10/3/31(水) 20:53 回答
【64994】Re:一覧表のデータを別シートに転記したい。 AAA 10/3/31(水) 21:06 お礼
【65004】一覧表のデータを別シートに転記したい。 AAA 10/4/1(木) 16:41 質問
【65009】Re:一覧表のデータを別シートに転記したい。 Hirofumi 10/4/1(木) 17:35 回答
【65016】Re:一覧表のデータを別シートに転記したい。 Hirofumi 10/4/2(金) 0:31 回答
【65017】一覧表のデータを別シートに転記したい。 AAA 10/4/2(金) 8:48 お礼

17228 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free