Question

我的工作簿有2张纸，第一张纸有信息列表，第二张纸是表格。我需要遍历第一张工作表上的每一行并将该信息放入表单，然后将该工作表另存为新工作簿并从某个单元格中进行命名。我基本上拥有了所有这些，我只需要将其放入循环中，并在每次循环时将其添加到范围中即可。这就是我得到的，有没有一种简单的方法可以使其循环并向范围中添加一个。谢谢。

Sub Range_Copy()

   Worksheets("Sheet1").Range("J2").Copy Worksheets("Sheet4").Range("K3:O3")
   Worksheets("Sheet1").Range("K2").Copy Worksheets("Sheet4").Range("E3:H3")
   Worksheets("Sheet1").Range("A2").Copy Worksheets("Sheet4").Range("A1:O1")
   Worksheets("Sheet1").Range("B2").Copy Worksheets("Sheet4").Range("E29:F29")
   Worksheets("Sheet1").Range("C2").Copy Worksheets("Sheet4").Range("G29:H29")
   Worksheets("Sheet1").Range("D2").Copy Worksheets("Sheet4").Range("D7:O7")
   Worksheets("Sheet1").Range("E2").Copy Worksheets("Sheet4").Range("L8:O8")
   Worksheets("Sheet1").Range("F2").Copy Worksheets("Sheet4").Range("D8:G8")
   Worksheets("Sheet1").Range("G2").Copy Worksheets("Sheet4").Range("D9:O9")
   Worksheets("Sheet1").Range("H2").Copy Worksheets("Sheet4").Range("D6:O6")
   Worksheets("Sheet1").Range("I2").Copy Worksheets("Sheet4").Range("A48:O48")

   Application.ScreenUpdating = False
   ActiveSheet.Select
   ActiveSheet.Copy
   ThisFile = Range("A1").Value
   ActiveSheet.SaveAs Filename:="H:\Intern Work\Server List\Server Form List\" & 
   ThisFile & ".xlsx"
   Application.ScreenUpdating = True
   ActiveWorkbook.Close
End Sub

Answer 1

可以肯定这就是您要查找的内容，但是我不确定在尝试保存600个单个文件时是否遇到任何障碍-

Sub Range_Copy()

Dim i As Long, lastrow As Long
Dim sht As Worksheet, sht2 As Worksheet, newwb As Workbook

Set sht = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet4")
lastrow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For i = 2 To lastrow

    sht2.Range("A1:O1").Value = sht.Range("A" & i).Value
    sht2.Range("E29:F29").Value = sht.Range("B" & i).Value
    sht2.Range("G29:H29").Value = sht.Range("C" & i).Value
    sht2.Range("D7:O7").Value = sht.Range("D" & i).Value
    sht2.Range("L8:O8").Value = sht.Range("E" & i).Value
    sht2.Range("D8:G8").Value = sht.Range("F" & i).Value
    sht2.Range("D9:O9").Value = sht.Range("G" & i).Value
    sht2.Range("D6:O6").Value = sht.Range("H" & i).Value
    sht2.Range("A48:O48").Value = sht.Range("I" & i).Value
    sht2.Range("K3:O3").Value = sht.Range("J" & i).Value
    sht2.Range("E3:H3").Value = sht.Range("K" & i).Value

    Set newwb = Workbooks.Add
    sht2.Copy Before:=newwb.Sheets(1)
    newwb.SaveAs Filename:="H:\Intern Work\Server List\Server Form List\" & sht2.Range("A1").Value & ".xlsx"
    newwb.Close False

Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

循环并将其添加到范围

1 个答案: