memo2024022402

Sub kopipe()




Dim lastrow As Long '行数カウント用の変数
lastrow = Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Dim i, j, k, l As Long
With Worksheets("sheet1")
For i = 1 To lastrow
j = i + 1
l = .Cells(i, 1).Value
k = l + 1

    If .Cells(i, 2).Value = "#" Then
        .Range(Cells(j, 2), Cells(j, 5)).Copy
        .Range(Cells(k, 9), Cells(k, 12)).PasteSpecial Paste:=xlPasteValues
        
        ElseIf .Cells(i, 2).Value = "質問" Then
        .Cells(j, 2).Copy
        .Cells(k, 13).PasteSpecial Paste:=xlPasteAll
        
        ElseIf .Cells(i, 2).Value = "回答" Then
        .Cells(j, 2).Copy
        .Cells(k, 14).PasteSpecial Paste:=xlPasteAll
        
    End If
Next i
End With
    MsgBox "kopipe完了"
    
End Sub

A列　転記するときのROW番号　変数ｋ
Ｂ列　抽出したデータ【転記するデータ）
F列　セルが"質問"かどうかの判定
F列の関数→　＝IF(B1="質問",1,"")
A1 =1
A2=1
A3=IF(F3="",A2,A2+F3)

Sub 追加()
Dim i, j, k, l, m As Long
Dim lastrow As Long '行数カウント用の変数
lastrow = Worksheets("sheet1").Cells(Rows.Count, 2).End(xlUp).Row

For i = 1 To lastrow
k = 2
j = i + 1
l = Worksheets("sheet1").Cells(i, 1).Value
m = l + 1

   If Worksheets("sheet1").Cells(i, 2).Value = "質問2" Then
      Worksheets("sheet1").Cells(j, 2).Copy
            Worksheets("sheet1").Cells(m, 15).PasteSpecial Paste:=xlPasteAll
    ElseIf Worksheets("sheet1").Cells(i, 2).Value = "質問3" Then
      Worksheets("sheet1").Cells(j, 2).Copy
            Worksheets("sheet1").Cells(m, 17).PasteSpecial Paste:=xlPasteAll
    ElseIf Worksheets("sheet1").Cells(i, 2).Value = "質問4" Then
      Worksheets("sheet1").Cells(j, 2).Copy
            Worksheets("sheet1").Cells(m, 19).PasteSpecial Paste:=xlPasteAll
            
    ElseIf Worksheets("sheet1").Cells(i, 2).Value = "回答2" Then
      Worksheets("sheet1").Cells(j, 2).Copy
            Worksheets("sheet1").Cells(m, 16).PasteSpecial Paste:=xlPasteAll

    ElseIf Worksheets("sheet1").Cells(i, 2).Value = "回答3" Then
      Worksheets("sheet1").Cells(j, 2).Copy
            Worksheets("sheet1").Cells(m, 18).PasteSpecial Paste:=xlPasteAll
    ElseIf Worksheets("sheet1").Cells(i, 2).Value = "回答4" Then
      Worksheets("sheet1").Cells(j, 2).Copy
            Worksheets("sheet1").Cells(m, 20).PasteSpecial Paste:=xlPasteAll
 

End If
Next
MsgBox "完了"
            
End Sub