不同文件之间的单元格范围的有条件复制
我想弄清楚如何在Excelmacros中实现以下algorithm。 我有两个我想合并的excel文件，我们称它们为fileA和fileB，macros是在fileB中。 我想要做的是以下几点：
do{ if cells(N,j) of file A is not empy{ //where N is the column and j is the row copy content of range (Nj:Pj) of fileA into fileB; j++; } while(fileA.Cells(H,j) is not empty 有没有人可以帮助我？ 谢谢丹
我已经为您的要求提供了框架模式，仔细研究一下
Sub test1() Dim wb1 As Workbook Dim wb2 As Workbook Dim ws1 As Worksheet Dim ws2 As Worksheet Dim file1 As String Dim file2 As String Dim j, N as Long j =1 N =1 ' File Path file1 = "C\test1.xlsx" file2 = "C\test2.xlsx" ' File Opening Set wb1 = Workbooks.Open(Filename:=file1) Set wb2 = Workbooks.Open(Filename:=file2) ' Assigning sheet Set ws1 = wb1.Worksheets("sheet1") Set ws2 = wb2.Worksheets("sheet1") ' use Do and loop statement ' Cells( Row, Column Number) Do ' I have used length to check the if it is empty or not If Len(ws1.Cells(j, N).Value) > 0 Then ' Provide appropriate column number and row number ' For example A column, Column number is 1, B it is 2 ' from copy range is ws1.Cells(Row1, col1) ' To copy range is ws1.Cells(Row2, col2) ws1.Range(ws1.Cells(Row1, col1), ws1.Cells(row2, col2)).Copy ws2.Paste ws2.Cells(Row3, col3) Application.CutCopyMode = False Application.CutCopyMode = True End If j = j + 1 Loop Until Len((ws1.Cells(j, N).Value)) > 0 End Sub
只是为了有一个可行的解决scheme试试这个：
'this will check the given upper cell for each row in your target 'if it is empty, it will copy the same range of your source to it 'it stops as soon as the given upper cell in your source is empty Sub test() Dim wsCopy As Worksheet, wsPaste As Worksheet Dim x As Long, y As Long, z As Long 'x = upper row / y = column / z = lower row Set wsCopy = Workbooks("FileA.xlsm").Worksheets("Sheet1") 'your source-workbook Set wsPaste = ThisWorkbook.Worksheets("Sheet1") ' your target-workbook x = 1 'set the row to check here y = 1 'set the first column to check here z = 1 'set the lower row for the range to copy Do If IsEmpty(wsPaste.Cells(x, y)) Then wsPaste.Range(Cells(x, y), Cells(z, y)) = wsCopy.Range(Cells(x, y), Cells(z, y)) End If y = y + 1 Loop Until IsEmpty(wsCopy.Cells(x, y)) End Sub
或另一个：
'note: this will copy entire columns 'it skips columns which are not empty in your target worksheet 'it stops at the first empty column in your source worksheet Sub test() Dim wsCopy As Worksheet, wsPaste As Worksheet Dim y As Long ' y = column Set wsCopy = Workbooks("FileA.xlsm").Worksheets("Sheet1") 'your source-workbook Set wsPaste = ThisWorkbook.Worksheets("Sheet1") ' your target-workbook y = 1 'set the first column to check here Do If IsEmpty(wsPaste.Cells(Rows.Count, y).End(xlUp)) Then wsPaste.Column(y) = wsCopy.Column(y) End If y = y + 1 Loop While IsEmpty(wsCopy.Cells(Rows.Count, y).End(xlUp)) End Sub
两者都不会复制任何格式
但是：如果你想也复制它然后改变：
'for the first change wsPaste.Range(Cells(x, y), Cells(z, y)) = wsCopy.Range(Cells(x, y), Cells(z, y)) 'to wsCopy.Range(Cells(x, y), Cells(z, y)).Copy wsPaste.Range(Cells(x, y), Cells(z, y)).Paste 'for the second change wsPaste.Column(y) = wsCopy.Column(y) 'to wsCopy.Column(y).Copy wsPaste.Column(y).Paste
首先，感谢所有帮助我解决这个问题的人。 为了让它工作，我必须调整提出的解决scheme。 请注意，由于它打开源文件和目标文件，因此必须将该macros放入第三个文件。 以下代码：
Private Function get_user_specified_filepath(index As Integer) As String 'This function is obtain the strings containing source and destination files, along with their path. Dim fd As Office.FileDialog Set fd = Application.FileDialog(msoFileDialogFilePicker) fd.AllowMultiSelect = False If (index = 1) Then fd.Title = "Please select source file." Else fd.Title = "Please select destination file." End If If fd.Show = -1 Then get_user_specified_filepath = fd.SelectedItems(1) Else End If End Function Sub test1() Dim wb1 As Workbook Dim wb2 As Workbook Dim ws1 As Worksheet Dim ws2 As Worksheet Dim file1, sConflicts As String Dim file2 As String Dim j, H, N, Q As Long Dim index As Integer Dim conflicts As Long conflicts = 0 index = 1 j = 2 ' These variables are helpers used to identify column index H = 8 N = 14 Q = 17 R = 18 S = 19 V = 22 ' File Opening Set wb1 = Workbooks.Open(get_user_specified_filepath(index)) 'index is used to manage source/dst in the dialog output index = 2 Set wb2 = Workbooks.Open(get_user_specified_filepath(index)) ' Assigning sheet Set ws1 = wb1.Worksheets("Foglio2") Set ws2 = wb2.Worksheets("Foglio2") ' use Do and loop statement ' Cells( Row, Column Number) Application.ScreenUpdating = False Do If Not IsEmpty(ws1.Cells(j, N)) Then ' Provide appropriate column number and row number ' For example A column, Column number is 1, B it is 2 ' from copy range is ws1.Cells(Row1, col1) ' To copy range is ws1.Cells(Row2, col2) ws1.Range(ws1.Cells(j, N), ws1.Cells(j, Q)).Copy 'check for conflicts in the destination Range If IsEmpty(ws2.Cells(j, N)) Then 'ws2.Range(ws2.Cells(j, N), ws2.Cells(j, Q)).PasteSpecial ws2.Range(ws2.Cells(j, N), ws2.Cells(j, Q)).PasteSpecial ws2.Range(ws2.Cells(j, N), ws2.Cells(j, Q)).Interior.ColorIndex = 4 Else 'If conflicts are detected paste the cells on the right conflicts = conflicts + 1 ws2.Paste ws2.Cells(j, S) ws2.Range(ws2.Cells(j, S), ws2.Cells(j, V)).Interior.ColorIndex = 7 End If 'Are these actually needed here? Application.CutCopyMode = False Application.CutCopyMode = True End If j = j + 1 Loop Until Not Len(ws2.Cells(j, R).Value) > 0 If (conflicts > 0) Then 'After completion of the check, outputs the total number of conflicts detected sConflicts = "Please check for conflicts, total: " & conflicts MsgBox sConflicts End If wb1.Close wb2.Close Application.ScreenUpdating = False End Sub