いくつかのステップを進めるために選択されたシートだけをループする

Question

私はある列から別の列にコピーをコピーする必要があるいくつかのシートを含むExcelファイルを持っています。

特定のシートにコードを使用すると、それは完全に機能します。 Sheets（Array（ "ThisSheet"、 "ThatSheet"））。選択すると、部分的に処理されます。行131の後に切り捨てられたデータが間違った方向にペーストされるためです。それにもかかわらず、どのようにそれを解決するためのアイデア。

コードを教えてもらえますか？私はtrupyそれを感謝したい。コメントには、特定の列の名前しか見つからないので、簡単に入力してください。

Sub TABFixLoop_Main() 
' TABFix Macro Loop Core Scratch 
' === Declaces which tabs are in the loop ======== 
' === Exceptions: ES20, IT40, IT43, IT44, IT45, PT20 === 

Application.ScreenUpdating = False 

Dim ws As Worksheet 
Dim Sheets As Range 
Set Sheets = Sheets(Array("BE00", "CH10", "CZ00", "DK00", "ES00", "FI00", "IT00", "LU30", "NL00", "NO00", "PT00", "SE00")) 
For Each ws In Sheets 
    Do 
    ' Fit the columns size 
    ws.Activate 
    ws.Columns.AutoFit 

    ' Putting value ranges in correct places: 

    ' MMDoC# 
    Range("P5").Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Selection.Copy 
    Range("N5").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
    ws.Columns("N:N").Select 
    Selection.NumberFormat = "0" 
    Range("P5").Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Application.CutCopyMode = False 
    Selection.ClearContents 

    ' Age 
    Range("Q5").Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Selection.Copy 
    Range("O5").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
    Range("Q5").Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Application.CutCopyMode = False 
    Selection.ClearContents 

    ' PO Vendor 
    Range("R5").Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Selection.Cut 
    Application.CutCopyMode = False 
    Selection.Copy 
    Range("P5").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
    Range("P5").NumberFormat = "0" 
    Range("R5").Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Application.CutCopyMode = False 
    Selection.ClearContents 

    ' Business Area 
    Range("S5").Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Selection.Copy 
    Range("R5").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
    Range("S5").Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Application.CutCopyMode = False 
    Selection.ClearContents 

    ' Remove empty columns 
    ws.Columns("S:T").Select 
    Selection.Delete Shift:=xlToLeft 

    ' Add formula to count aging ranges 
    Range("U5").Select 
    ActiveCell.FormulaR1C1 = "=+IF(RC[-6]<=30,""0-30"",IF(RC[-6]<=60,""31-60"",IF(RC[-6]<=90,""61-90"",IF(RC[-6]<=120,""91-120"",IF(RC[-6]<=180,""121-180"",IF(RC[-6]<=365,""181-365"",IF(RC[-6]>365,"">365"","""")))))))" 
    Range(Selection, Selection.End(xlDown)).Select 
    Selection.FillDown 
    Loop Until ws = Sheets(Sheets.Count).Active 
    Application.ScreenUpdating = True 

End Sub 

Answer 1

Sub test() 
Dim ws As Worksheet 

For Each ws In Worksheets 
    Select Case ws.Name 
     Case "BE00", "CH10", "CZ00", "DK00", "ES00", "FI00", "IT00", "LU30", "NL00", "NO00", "PT00", "SE00" 
      ws.Columns.AutoFit 
      shiftdata ws, "P", "N" 
      shiftdata ws, "Q", "O" 
      shiftdata ws, "R", "P" 
      With ws.Range("U5") 
       .FormulaR1C1 = "=+IF(RC[-6]<=30,""0-30"",IF(RC[-6]<=60,""31-60"",IF(RC[-6]<=90,""61-90"",IF(RC[-6]<=120,""91-120"",IF(RC[-6]<=180,""121-180"",IF(RC[-6]<=365,""181-365"",IF(RC[-6]>365,"">365"","""")))))))" 
       .Copy Destination := ws.Range(.Address & ":" & .End(xlDown).Address) 
      End With 
     Case Else 


    End Select 
Next ws 
End Sub 

Sub shiftdata(ws As Worksheet, strFrom As String, StrTo As String) 
Dim r As Range 

    Set r = ws.Range(strFrom & "5:" & strFrom & ws.Range(strFrom & "5").End(xlDown).Row) 
    r.Copy 
    ws.Range(StrTo & "5").PasteSpecial xlPasteValues 
    r.ClearContents 
End Sub