マクロ｜白丸くん

Sub ピックアップして貼り付け()
    Dim シート1 As Worksheet
    Dim シート2 As Worksheet
    Dim 行数 As Long
    Dim i As Long
    Dim j As Long
    
    ' シート1とシート2を指定
    Set シート1 = ThisWorkbook.Sheets("シート1の名前")
    Set シート2 = ThisWorkbook.Sheets("シート2の名前")
    
    ' データをコピー
    行数 = シート1.Cells(シート1.Rows.Count, 1).End(xlUp).Row ' シート1の最終行を取得
    j = 2 ' シート2の行の開始位置
    
    ' シート1からデータをピックアップしてシート2に貼り付け
    For i = 2 To 行数 Step 5 ' 2行目から5行おきにピックアップ
        シート1.Rows(i).Copy シート2.Rows(j) ' シート1からシート2にコピー
        j = j + 1 ' 次の行に移動
    Next i
    
    ' メッセージを表示
    MsgBox "データをピックアップして貼り付けしました。"
End Sub




Sub 抽出して貼り付ける()
    Dim SourceSheet As Worksheet
    Dim TargetSheet As Worksheet
    Dim SourceRange As Range
    Dim TargetRow As Long
    Dim i As Long
    
    ' Sheet1をソースシートとして設定
    Set SourceSheet = ThisWorkbook.Sheets("Sheet1")
    
    ' Sheet2をターゲットシートとして設定
    Set TargetSheet = ThisWorkbook.Sheets("Sheet2")
    
    ' ターゲットシートの最終行を取得
    TargetRow = TargetSheet.Cells(TargetSheet.Rows.Count, "A").End(xlUp).Row + 1
    
    ' ソースシートのデータを2行目から5行ごとに抽出し、ターゲットシートに貼り付け
    For i = 2 To SourceSheet.Cells(SourceSheet.Rows.Count, "A").End(xlUp).Row Step 5
        Set SourceRange = SourceSheet.Range("A" & i).Resize(5, SourceSheet.UsedRange.Columns.Count)
        SourceRange.Copy TargetSheet.Cells(TargetRow, 1)
        TargetRow = TargetRow + 5
    Next i
End Sub



Sub 抽出して貼り付ける()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    
    ' ワークシート1とワークシート2を設定
    Set ws1 = ThisWorkbook.Sheets("シート1") ' シート1の名前を適宜変更してください
    Set ws2 = ThisWorkbook.Sheets("シート2") ' シート2の名前を適宜変更してください
    
    ' シート1の最終行を取得
    lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    
    ' シート2の行インデックスを初期化
    j = 2
    
    ' データを5行ごとに抽出してシート2に貼り付ける
    For i = 2 To lastRow Step 5
        ws1.Rows(i & ":" & i + 4).Copy ws2.Cells(j, 1)
        j = j + 5
    Next i
End Sub


Sub ImportPNGFiles()
    Dim FolderPath As String
    Dim FileName As String
    Dim LastRow As Long
    
    ' フォルダの選択ダイアログを表示
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            FolderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    ' A列の最終行を取得
    LastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
    ' フォルダ内のPNGファイルを処理
    FileName = Dir(FolderPath & "\*.png")
    Do While FileName <> ""
        LastRow = LastRow + 1
        ThisWorkbook.Sheets("Sheet1").Cells(LastRow, 1).Select
        ActiveSheet.Pictures.Insert(FolderPath & "\" & FileName).Select
        Selection.ShapeRange.LockAspectRatio = msoTrue
        Selection.ShapeRange.Width = 100 ' 画像の幅を調整する場合、適宜調整してください
        Selection.ShapeRange.Height = 100 ' 画像の高さを調整する場合、適宜調整してください
        FileName = Dir
    Loop
End Sub



Sub 図形の調整()
    Dim shp As Shape
    Dim leftMost As Double
    
    ' 左端の位置を特定
    leftMost = ActiveSheet.Cells(1, 1).Left
    
    ' シート上の全ての図形を選択
    For Each shp In ActiveSheet.Shapes
        shp.Select (False)
    Next shp
    
    ' 図形の大きさを揃える
    Selection.ShapeRange.Align msoAlignLefts, True
    Selection.ShapeRange.Align msoAlignTops, False
    
    ' 左端に揃える
    For Each shp In ActiveSheet.Shapes
        If shp.Left < leftMost Then
            leftMost = shp.Left
        End If
    Next shp
    
    Selection.ShapeRange.IncrementLeft -leftMost
End Sub



Sub ArrangeShapes()
    Dim ws As Worksheet
    Dim shp As Shape
    Dim leftMost As Double
    Dim i As Integer

    ' アクティブなシートを取得
    Set ws = ActiveSheet

    ' 左端の座標を初期化
    leftMost = ws.Shapes(1).Left

    ' 全ての図形を選択
    For Each shp In ws.Shapes
        shp.Select (True)
        If shp.Left < leftMost Then
            leftMost = shp.Left
        End If
    Next shp

    ' 選択した図形の大きさを揃える
    With Selection
        .Width = .Width / .Count
        .Height = .Height / .Count
    End With

    ' 左端に揃える
    For Each shp In ws.Shapes
        shp.Left = leftMost
    Next shp
End Sub



動作○
Sub 区切り文字列()
    Dim LastRow As Long
    Dim i As Long, j As Long
    Dim OriginalValue As String
    
    ' 最終行を取得
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    ' 各セルに対して処理を行う
    For i = 1 To LastRow
        OriginalValue = Cells(i, 1).Value
        ' セルの内容を1文字ずつ分割して表示
        For j = 1 To Len(OriginalValue)
            Cells(i, j + 1).Value = Mid(OriginalValue, j, 1)
        Next j
    Next i
End Sub


Sub 塗りつぶし()
    Dim LastRow As Long
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("シート名") ' シート名を適切に変更してください

    ' 最終行を取得
    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    ' 2列おきにセルを水色で塗りつぶす
    For i = 3 To LastRow Step 2
        ws.Range("A" & i).Resize(1, ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column).Interior.Color = RGB(173, 216, 230)
    Next i
End Sub



Sub 罫線を引く()
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim rng As Range
    
    ' ワークシートの最終行と最終列を取得
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    LastColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    
    ' 全てのセルに罫線を引く
    Set rng = ActiveSheet.Range(Cells(1, 1), Cells(LastRow, LastColumn))
    rng.BorderAround xlContinuous, xlMedium
End Sub

動作○
Sub 背景色を設定()
    Dim ws As Worksheet
    Dim LastRow As Long
    Dim i As Long
    
    ' 作業するシートを指定
    Set ws = ThisWorkbook.Sheets("シート名") ' シート名を適切なものに変更してください
    
    ' 最終行を取得
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 先頭行から3行目から始めて、2行おきに水色に塗りつぶす
    For i = 3 To LastRow Step 2
        ws.Range("A" & i & ":Z" & i).Interior.Color = RGB(173, 216, 230) ' RGBカラーコードで水色を指定
    Next i
End Sub


Sub DrawBorders()
    Dim LastRow As Long
    Dim LastCol As Long
    Dim Cell As Range
    
    ' 最終行と最終列を取得
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    LastCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    
    ' セルごとに罫線を引く
    For Each Cell In ActiveSheet.Range(Cells(1, 1), Cells(LastRow, LastCol))
        Cell.Borders.LineStyle = xlContinuous
    Next Cell
End Sub


Sub 抽出()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim j As Long

    ' Sheet1とSheet2を設定
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")

    ' Sheet1の最終行を取得
    lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row

    ' Sheet2をクリア
    ws2.Cells.Clear

    ' Sheet1のA列を確認し、条件に合致する行をSheet2にコピー
    j = 1 ' Sheet2の行カウンター
    For i = 2 To lastRow ' 2行目から最終行までループ
        If ws1.Cells(i, "A").Value >= 10 And ws1.Cells(i, "A").Value < 20 Then
            ws1.Rows(i).Copy ws2.Rows(j)
            j = j + 1
        End If
    Next i
End Sub



Sub 画像を挿入()
    Dim フォルダパス As String
    Dim ファイル名 As String
    Dim シート As Worksheet
    Dim 行数 As Integer
    Dim 画像 As Picture

    ' ダイアログボックスでフォルダを選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            フォルダパス = .SelectedItems(1)
        Else
            MsgBox "フォルダが選択されませんでした。"
            Exit Sub
        End If
    End With

    ' シート1をアクティブにする
    Set シート = ThisWorkbook.Sheets(1)

    ' フォルダ内のpngファイルを処理
    ファイル名 = Dir(フォルダパス & "\*.png")
    行数 = 1
    Do While ファイル名 <> ""
        ' 画像を挿入
        Set 画像 = シート.Pictures.Insert(フォルダパス & "\" & ファイル名)
        
        ' 画像のサイズを調整（必要に応じて）
        画像.ShapeRange.LockAspectRatio = msoFalse
        画像.Height = シート.Rows(行数).Height
        画像.Width = シート.Columns("A").Width
        
        ' 次の行に移動
        行数 = 行数 + 1
        
        ' 次のファイルを取得
        ファイル名 = Dir
    Loop
End Sub



Sub 選択した図形を揃える()
    Dim ws As Worksheet
    Dim shp As Shape
    Dim selectedShapes As Object

    ' 現在のシートを取得
    Set ws = ActiveSheet

    ' すべての図形を選択
    ws.Shapes.SelectAll

    ' 選択された図形を取得
    Set selectedShapes = Selection.ShapeRange

    ' 選択された図形が存在するか確認
    If Not selectedShapes Is Nothing Then
        ' 図形のサイズを揃える
        selectedShapes.Align msoAlignTops, msoTrue
        selectedShapes.Align msoAlignLefts, msoTrue
    Else
        MsgBox "選択された図形が見つかりません。", vbExclamation
    End If
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

Sub ピックアップして貼り付け()

Dim シート1 As Worksheet

Dim シート2 As Worksheet

Dim 行数 As Long

Dim i As Long

Dim j As Long

' シート1とシート2を指定

Set シート1 = ThisWorkbook.Sheets("シート1の名前")

Set シート2 = ThisWorkbook.Sheets("シート2の名前")

' データをコピー

行数 = シート1.Cells(シート1.Rows.Count, 1).End(xlUp).Row ' シート1の最終行を取得

j = 2 ' シート2の行の開始位置

' シート1からデータをピックアップしてシート2に貼り付け

For i = 2 To 行数 Step 5 ' 2行目から5行おきにピックアップ

シート1.Rows(i).Copy シート2.Rows(j) ' シート1からシート2にコピー

j = j + 1 ' 次の行に移動

Next i

' メッセージを表示

MsgBox "データをピックアップして貼り付けしました。"

End Sub

Sub 抽出して貼り付ける()

Dim SourceSheet As Worksheet

Dim TargetSheet As Worksheet

Dim SourceRange As Range

Dim TargetRow As Long

Dim i As Long

' Sheet1をソースシートとして設定

Set SourceSheet = ThisWorkbook.Sheets("Sheet1")

' Sheet2をターゲットシートとして設定

Set TargetSheet = ThisWorkbook.Sheets("Sheet2")

' ターゲットシートの最終行を取得

TargetRow = TargetSheet.Cells(TargetSheet.Rows.Count, "A").End(xlUp).Row + 1

' ソースシートのデータを2行目から5行ごとに抽出し、ターゲットシートに貼り付け

For i = 2 To SourceSheet.Cells(SourceSheet.Rows.Count, "A").End(xlUp).Row Step 5

Set SourceRange = SourceSheet.Range("A" & i).Resize(5, SourceSheet.UsedRange.Columns.Count)

SourceRange.Copy TargetSheet.Cells(TargetRow, 1)

TargetRow = TargetRow + 5

Next i

End Sub

Sub 抽出して貼り付ける()

Dim ws1 As Worksheet

Dim ws2 As Worksheet

Dim lastRow As Long

Dim i As Long

Dim j As Long

' ワークシート1とワークシート2を設定

Set ws1 = ThisWorkbook.Sheets("シート1") ' シート1の名前を適宜変更してください

Set ws2 = ThisWorkbook.Sheets("シート2") ' シート2の名前を適宜変更してください

' シート1の最終行を取得

lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row

' シート2の行インデックスを初期化

j = 2

' データを5行ごとに抽出してシート2に貼り付ける

For i = 2 To lastRow Step 5

ws1.Rows(i & ":" & i + 4).Copy ws2.Cells(j, 1)

j = j + 5

Next i

End Sub

Sub ImportPNGFiles()

Dim FolderPath As String

Dim FileName As String

Dim LastRow As Long

' フォルダの選択ダイアログを表示

With Application.FileDialog(msoFileDialogFolderPicker)

If .Show = -1 Then

FolderPath = .SelectedItems(1)

Else

Exit Sub

End If

End With

' A列の最終行を取得

LastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

' フォルダ内のPNGファイルを処理

FileName = Dir(FolderPath & "\*.png")

Do While FileName <> ""

LastRow = LastRow + 1

ThisWorkbook.Sheets("Sheet1").Cells(LastRow, 1).Select

ActiveSheet.Pictures.Insert(FolderPath & "\" & FileName).Select

Selection.ShapeRange.LockAspectRatio = msoTrue

Selection.ShapeRange.Width = 100 ' 画像の幅を調整する場合、適宜調整してください

Selection.ShapeRange.Height = 100 ' 画像の高さを調整する場合、適宜調整してください

FileName = Dir

Loop

End Sub

Sub 図形の調整()

Dim shp As Shape

Dim leftMost As Double

' 左端の位置を特定

leftMost = ActiveSheet.Cells(1, 1).Left

' シート上の全ての図形を選択

For Each shp In ActiveSheet.Shapes

shp.Select (False)

Next shp

' 図形の大きさを揃える

Selection.ShapeRange.Align msoAlignLefts, True

Selection.ShapeRange.Align msoAlignTops, False

' 左端に揃える

For Each shp In ActiveSheet.Shapes

If shp.Left < leftMost Then

leftMost = shp.Left

End If

Next shp

Selection.ShapeRange.IncrementLeft -leftMost

End Sub

Sub ArrangeShapes()

Dim ws As Worksheet

Dim shp As Shape

Dim leftMost As Double

Dim i As Integer

' アクティブなシートを取得

Set ws = ActiveSheet

' 左端の座標を初期化

leftMost = ws.Shapes(1).Left

' 全ての図形を選択

For Each shp In ws.Shapes

shp.Select (True)

If shp.Left < leftMost Then

leftMost = shp.Left

End If

Next shp

' 選択した図形の大きさを揃える

With Selection

.Width = .Width / .Count

.Height = .Height / .Count

End With

' 左端に揃える

For Each shp In ws.Shapes

shp.Left = leftMost

Next shp

End Sub

動作○

Sub 区切り文字列()

Dim LastRow As Long

Dim i As Long, j As Long

Dim OriginalValue As String

' 最終行を取得

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

' 各セルに対して処理を行う

For i = 1 To LastRow

OriginalValue = Cells(i, 1).Value

' セルの内容を1文字ずつ分割して表示

For j = 1 To Len(OriginalValue)

Cells(i, j + 1).Value = Mid(OriginalValue, j, 1)

Next j

Next i

End Sub

Sub 塗りつぶし()

Dim LastRow As Long

Dim ws As Worksheet

Set ws = ThisWorkbook.Sheets("シート名") ' シート名を適切に変更してください

' 最終行を取得

LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

' 2列おきにセルを水色で塗りつぶす

For i = 3 To LastRow Step 2

ws.Range("A" & i).Resize(1, ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column).Interior.Color = RGB(173, 216, 230)

Next i

End Sub

Sub 罫線を引く()

Dim LastRow As Long

Dim LastColumn As Long

Dim rng As Range

' ワークシートの最終行と最終列を取得

LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

LastColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

' 全てのセルに罫線を引く

Set rng = ActiveSheet.Range(Cells(1, 1), Cells(LastRow, LastColumn))

rng.BorderAround xlContinuous, xlMedium

End Sub

動作○

Sub 背景色を設定()

Dim ws As Worksheet

Dim LastRow As Long

Dim i As Long

' 作業するシートを指定

Set ws = ThisWorkbook.Sheets("シート名") ' シート名を適切なものに変更してください

' 最終行を取得

LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' 先頭行から3行目から始めて、2行おきに水色に塗りつぶす

For i = 3 To LastRow Step 2

ws.Range("A" & i & ":Z" & i).Interior.Color = RGB(173, 216, 230) ' RGBカラーコードで水色を指定

Next i

End Sub

Sub DrawBorders()

Dim LastRow As Long

Dim LastCol As Long

Dim Cell As Range

' 最終行と最終列を取得

LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

LastCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

' セルごとに罫線を引く

For Each Cell In ActiveSheet.Range(Cells(1, 1), Cells(LastRow, LastCol))

Cell.Borders.LineStyle = xlContinuous

Next Cell

End Sub

Sub 抽出()

Dim ws1 As Worksheet

Dim ws2 As Worksheet

Dim lastRow As Long

Dim i As Long

Dim j As Long

' Sheet1とSheet2を設定

Set ws1 = ThisWorkbook.Sheets("Sheet1")

Set ws2 = ThisWorkbook.Sheets("Sheet2")

' Sheet1の最終行を取得

lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row

' Sheet2をクリア

ws2.Cells.Clear

' Sheet1のA列を確認し、条件に合致する行をSheet2にコピー

j = 1 ' Sheet2の行カウンター

For i = 2 To lastRow ' 2行目から最終行までループ

If ws1.Cells(i, "A").Value >= 10 And ws1.Cells(i, "A").Value < 20 Then

ws1.Rows(i).Copy ws2.Rows(j)

j = j + 1

End If

Next i

End Sub

Sub 画像を挿入()

Dim フォルダパス As String

Dim ファイル名 As String

Dim シート As Worksheet

Dim 行数 As Integer

Dim 画像 As Picture

' ダイアログボックスでフォルダを選択

With Application.FileDialog(msoFileDialogFolderPicker)

If .Show = -1 Then

フォルダパス = .SelectedItems(1)

Else

MsgBox "フォルダが選択されませんでした。"

Exit Sub

End If

End With

' シート1をアクティブにする

Set シート = ThisWorkbook.Sheets(1)

' フォルダ内のpngファイルを処理

ファイル名 = Dir(フォルダパス & "\*.png")

行数 = 1

Do While ファイル名 <> ""

' 画像を挿入

Set 画像 = シート.Pictures.Insert(フォルダパス & "\" & ファイル名)

' 画像のサイズを調整（必要に応じて）

画像.ShapeRange.LockAspectRatio = msoFalse

画像.Height = シート.Rows(行数).Height

画像.Width = シート.Columns("A").Width

' 次の行に移動

行数 = 行数 + 1

' 次のファイルを取得

ファイル名 = Dir

Loop

End Sub

Sub 選択した図形を揃える()

Dim ws As Worksheet

Dim shp As Shape

Dim selectedShapes As Object

' 現在のシートを取得

Set ws = ActiveSheet

' すべての図形を選択

ws.Shapes.SelectAll

' 選択された図形を取得

Set selectedShapes = Selection.ShapeRange

' 選択された図形が存在するか確認

If Not selectedShapes Is Nothing Then

' 図形のサイズを揃える

selectedShapes.Align msoAlignTops, msoTrue

selectedShapes.Align msoAlignLefts, msoTrue

Else

MsgBox "選択された図形が見つかりません。", vbExclamation

End If

End Sub

サンプル

1000分は何時間何分で何時間（少数・分数）？16時間40分は何分？

おすすめのDHA・EPAサプリ【私の経験】

直感で職場が合わないと感じたらすぐ辞める（転職）のはありか【合わない仕事は辞めるべき】

アイリスオーヤマ社ホットプレートDPOL-301とDPO-133との違いは？口コミ・評判・使い方も徹底解説！

【DHA・EPA】さかな暮らしの効果を徹底解説【実際に飲んだ結果】

ハピネスのマンボウサンQの効果と口コミ【実証結果】

【Excel】エクセルで同じ名前のカウントを行う方法【単語の出現回数】

職場がうるさいのがストレスな場合の対策は？ 【隣の席がうるさい】

おすすめのDHA・EPAサプリ【私の経験】

職場がうるさいのがストレスな場合の対策は？【隣の席がうるさい】