-1
1つのExcelファイルからいくつかのデータに分割するマクロが必要です。私は自分のファイルを持っているために、すべてのユーザーが必要テンプレートをマクロと一緒にファイルに分割するブックを分割する
WW_DDAVIS.xls
User Role
DDAVIS XX
DDAVIS XS
WP_GROBERT.xls
User Role
GROBERT XW
AA_SJOBS.xls
User Role
SJOBS XX
SJOBS XS
SJOBS XW
：
UserList.xls
User Role Location
DDAVIS XX WW
DDAVIS XS WW
GROBERT XW WP
SJOBS XX AA
SJOBS XS AA
SJOBS XW AA
私はこのようなデータをコピーするために、必要があります。それはこのようになります。この問題は、テンプレート（template.xls）を使用してファイルを埋め込む必要があると伝えられたときに表示されました。同じように見えますが、ソースファイル内のデータはセルA2、セルA8のテンプレートファイルから始まります。私はこのコードを使用するテンプレートせずにデータをコピーするには
：この1で
Public Sub SplitToFiles()
' MACRO SplitToFiles
' Last update: 2012-03-04
' Author: mtone
' Version 1.1
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
'
' Note: Values in the column should be unique or sorted.
'
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
'
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.
Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created
iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
iFirstRow = iRow
Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path
If Dir(sFilePath + "\Split", vbDirectory) = "" Then
MkDir sFilePath + "\Split"
End If
'Turn Off Screen Updating Events
Application.EnableEvents = False
Application.ScreenUpdating = False
Do
' Get cell at cursor
Set rCell = osh.Cells(iRow, iCol)
sCell = Replace(rCell.Text, " ", "")
If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
' Skip condition met
Else
' Found new section
If iStartRow = 0 Then
' StartRow delimiter not set, meaning beginning a new section
sSectionName = rCell.Text
iStartRow = iRow
Else
' StartRow delimiter set, meaning we reached the end of a section
iStopRow = iRow - 1
' Pass variables to a separate sub to create and save the new worksheet
CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
iCount = iCount + 1
' Reset section delimiters
iStartRow = 0
iStopRow = 0
' Ready to continue loop
iRow = iRow - 1
End If
End If
' Continue until last row is reached
If iRow < iTotalRows Then
iRow = iRow + 1
Else
' Finished. Save the last section
iStopRow = iRow
CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
iCount = iCount + 1
' Exit
Exit Do
End If
Loop
'Turn On Screen Updating Events
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox Str(iCount) + " documents saved in " + sFilePath
End Sub
Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)
Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete
End Sub
Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
Dim ash As Worksheet ' Copied sheet
Dim awb As Workbook ' New workbook
' Copy book
osh.Copy
Set ash = Application.ActiveSheet
' Delete Rows after section
If iTotalRows > iStopRow Then
DeleteRows ash, iStopRow + 1, iTotalRows
End If
' Delete Rows before section
If iStartRow > iFirstRow Then
DeleteRows ash, iFirstRow, iStartRow - 1
End If
' Select left-topmost cell
ash.Cells(1, 1).Select
' Clean up a few characters to prevent invalid filename
sSectionName = Replace(sSectionName, "/", " ")
sSectionName = Replace(sSectionName, "\", " ")
sSectionName = Replace(sSectionName, ":", " ")
sSectionName = Replace(sSectionName, "=", " ")
sSectionName = Replace(sSectionName, "*", " ")
sSectionName = Replace(sSectionName, ".", " ")
sSectionName = Replace(sSectionName, "?", " ")
' Save in same format as original workbook
ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat
' Close
Set awb = ash.Parent
awb.Close SaveChanges:=False
End Sub
問題、私は名前ではないDDAVIS.xlsを作成する方法が分からないということですが、WW_DDAVIS.xls（location_userを使用。 xls）。第2の問題 - テンプレートを使用する。このコードはブック全体をコピーし、間違ったデータをすべて消去します。私が必要とするのは、正しいデータの価値をこのテンプレートにコピーすることだけです。
残念なことに私は作業コードを見つけられず、VBAを流暢に使用することができません。
私は他のものを試しましたが、それは半分でしか動作しませんでした。テンプレートをすべてのファイルにコピーして適切に名前を付けましたが、セルを正しいファイルにコピーする方法がわかりませんでした。
Option Explicit
Sub copyTemplate()
Dim lRow, x As Integer
Dim wbName As String
Dim fso As Variant
Dim dic As Variant
Dim colA As String
Dim colB As String
Dim colSep As String
Dim copyFile As String
Dim copyTo As String
Set dic = CreateObject("Scripting.Dictionary") 'dictionary to ensure that duplicates are not created
Set fso = CreateObject("Scripting.FileSystemObject") 'file scripting object for fiile system manipulation
colSep = "_" 'separater between values of col A and col B for file name
dic.Add colSep, vbNullString ' ensuring that we never create a file when both columns are blank in between
'get last used row in col A
lRow = Range("A" & Rows.Count).End(xlUp).Row
x = 1
copyFile = "c:\location\Template.xls" 'template file to copy
copyTo = "C:\location\List\" 'location where copied files need to be copied
Do
x = x + 1
colA = Range("G" & x).Value 'col a value
colB = Range("A" & x).Value ' col b value
wbName = colA & colSep & colB ' create new file name
If (Not dic.Exists(wbName)) Then 'ensure that we have not created this file name before
fso.copyFile copyFile, copyTo & wbName & ".xls" 'copy the file
dic.Add wbName, vbNullString 'add to dictionary that we have created this file
End If
Loop Until x = lRow
Set dic = Nothing ' clean up
Set fso = Nothing ' clean up
End Sub