Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

20195 / 76735

←次へ　｜　前へ→


	【61962】Re:行の挿入について

mori - 09/6/15(月) 9:48 -


	引用なし

	パスワード

かみちゃんさん

何度も何度もありがとうございます。
取り急ぎ、全体を提示します。

Sub CreateMitsumori()

　Dim i　　　　　　　　　 As Long
　Dim j　　　　　　　　　 As Long
　Dim k　　　　　　　　　 As Long
　Dim l　　　　　　　　　 As Long
　Dim m　　　　　　　　　 As Long
　Dim n　　　　　　　　　 As Long
　Dim lngMaxRow　　　　　 As Long
　Dim lngRow　　　　　　　As Long
　Dim blnFlag　　　　　　 As Boolean
　Dim lngCount　　　　　　As Long
　Dim strName　　　　　　 As String
　Dim lngPresentRowIndex　 As Long
　Dim lngRowX　　　　　　 As Long
　Dim lngRowY　　　　　　 As Long
　Dim strRangeValue　　　 As String
　Dim lngFooterRowIndex　 As Long

　
　Dim strGyoNO As String
　Dim strTekiyo As String
　Dim strSuryo As String
　Dim strTani As String
　Dim strTanka As String
　Dim strKingaku As String
　Dim strSyokei As String
　
　Dim strKakkoGyoNO As String
　Dim strKakkoKingaku As String
　Dim strTrimedTekiyo As String 'トリミング後
　Dim lngLength As Long
　Dim lngTekiyoLength As Long
　

　On Error GoTo Error_CreateMitsumori
　　
　With Worksheets(3)
　　'一時シートから行数を取得
　　lngMaxRow = Worksheets("TMP1").Range("A1").SpecialCells(xlLastCell).Row
　　blnFlag = False
　　j = 1
　　For i = 31 To lngMaxRow　　
　　　If j = 1 Then
　　　ElseIf j Mod 29 = 1 Then
　　　　.Range("A4:U32").Copy
　　　　lngRowY = j + 3
　　　　lngRowX = j + 31
　　　　strRangeValue = "A" & lngRowY & ":" & "U" & lngRowX
　　　　.Range(strRangeValue).PasteSpecial xlPasteAll
　　　　.Range(strRangeValue).RowHeight = 27
　　　　.PageSetup.PrintArea = .Range(strRangeValue)
　　　End If
　　　j = j + 1
　　Next
　　
　　lngPresentRowIndex = 4
　　For lngRow = 31 To lngMaxRow
　　　strGyoNO = Worksheets("TMP1").Cells(lngRow, 1).Value　　
　　　strTekiyo = Worksheets("TMP1").Cells(lngRow, 2).Value　
　　　strSuryo = Worksheets("TMP1").Cells(lngRow, 3).Value　　
　　　strTani = Worksheets("TMP1").Cells(lngRow, 4).Value　　
　　　strTanka = Worksheets("TMP1").Cells(lngRow, 5).Value　　
　　　strKingaku = Worksheets("TMP1").Cells(lngRow, 6).Value　
　　　strSyokei = Worksheets("TMP1").Cells(lngRow, 6).Value　
　　　
　　　'（）付行番号はCSV取込みすると－として認識されるので－を取り除きます
　　　If Left(strGyoNO, 1) = "-" Then
　　　　lngLength = Len(strGyoNO)
　　　　strKakkoGyoNO = Mid(strGyoNO, 2, lngLength - 1)
　　　　strKakkoGyoNO = "'(" & strKakkoGyoNO & ")"　　　　　　　　　
　　　　.Cells(lngPresentRowIndex, 1).Value = strKakkoGyoNO　　　　
　　　Else
　　　　.Cells(lngPresentRowIndex, 1).Value = strGyoNO　　　　　　　　　　　　　End If
　　　
　　　'文字列チェック
　　　strTrimedTekiyo = strTekiyo
　　　strTrimedTekiyo = StrConv(strTrimedTekiyo, 4)　　　　　　　　　 '半角スペースがあった場合全角にします
　　　strTrimedTekiyo = Replace(strTrimedTekiyo, "　", "")　　　　　　'トリミングします
　　　lngTekiyoLength = InStr(strTrimedTekiyo, "値引")　　　　　　　　'文字列"値引"の検索をし、文字位置を返します。無かった場合0を返します
　　　If lngTekiyoLength > 0 Then
　　　　strTrimedTekiyo = Mid(strTrimedTekiyo, lngTekiyoLength, 2)　　'値引を抜き出します
　　　End If
　　　
　　　If strTrimedTekiyo = "合計" Then　　　　　　　　　　　　　　　 '合計がある場合、小計欄のみに金額を挿入
　　　　.Cells(lngPresentRowIndex, 2).Value = strTekiyo
　　　　.Cells(lngPresentRowIndex, 6).Value = strKingaku
　　　ElseIf strTrimedTekiyo = "値引" Then
　　　　.Cells(lngPresentRowIndex, 2).Value = strTekiyo
　　　　.Cells(lngPresentRowIndex, 6).Value = strKingaku
　　　Else
　　　　.Cells(lngPresentRowIndex, 2).Value = strTekiyo
　　　　.Cells(lngPresentRowIndex, 3).Value = strSuryo
　　　　.Cells(lngPresentRowIndex, 4).Value = strTani
　　　　
　　　lngPresentRowIndex = lngPresentRowIndex + 1 'インデックスを加算

　　Next
　
　　End With
　　　　
Exit_CreateMitsumori:
　　Exit Sub

0 hits

▼

【61954】行の挿入について mori 09/6/14(日) 18:59