如何迭代一张纸中的每一列将每个列复制到不同的床单

Question

我正在尝试使用VBA实现以下目标：

我有两张纸："收入"one_answers"营业税"，他们从5月1日至5月28日记录了100家商店的收入和营业税。现在，我正在尝试为每家商店创建一张工作表，以记录从5月1日至5月28日的收入和营业税。

Sub test1()

    Sheets("Sheet1").Select
    Sheets("Sheet1").Copy Before:=Sheets(17)
    Sheets("revenue").Select
    Range("D154:D168").Select
    Selection.Copy
    Sheets("Sheet1 (2)").Select
    Range("C5").Select
    ActiveSheet.Paste
    Sheets("sales tax").Select
    Range("D138:D152").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1 (2)").Select
    Range("F5").Select
    ActiveSheet.Paste
    Sheets("Sheet1 (2)").Select
    Sheets("Sheet1 (2)").Name = " reportF "
End Sub

使用此代码我只能每次存储1个文件。我应该使用什么循环语法在所有商店中循环？

Answer 1

看起来您的数据在D列中具有存储名称？该代码在D列中沿所有单元格运行，并根据内容将它们复制成单独的床单

    Sub ExampleCode
    Dim r as range  'declare a pointer variable
    Dim ws as worksheet  'declare a worksheet variable
    set r = Range("d1")  'point to fist cell
    Do   'Start a loop
       If SheetNotExist(r.text) then  'if no sheet of that name
          set ws = worksheets.add(after:=worksheets.count)  'add one
          ws.name = r.text        'and name it as text in r
       End if
       r.copy worksheets(r.text).cells(rows.count,4).end(xlup).offset(1,0)  'copy to next blank cell
       set r = r.offset(1,0) 'shift pointer down one cell
    Loop until r.text = ""  'keep going until r is empty
    End Sub

   Function SheetNotExist(s as string) as boolean  'check if sheet exists
   On error goto nope  'jump on error
   Dim ws as worksheet
   set ws = worksheets(s)  'this will error if sheet doesn't exist
  'so if we get here the sheet does exist
   SheetNotExist = False 'so return false
   Exit Function 'and go back
   nope:  'we only get here if sheet doesn't exist
   SheetNotExist = True 'so return that
   End Function

写在我的手机上 - 没有Excel，因此可能会有错别字 - 代码可能不会编译，因此