我正在尝试弄清楚如何在Excel宏中实现以下算法。 我有两个我想要合并的excel文件，我们称之为fileA和fileB，宏在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
有没有人可以帮助我？ 谢谢， 丹
答案 0 :(得分：1)
我已根据您的要求提供了框架工作模式，请查看
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
答案 1 :(得分：0)
只是为了找到一个可行的解决方案，试试这个：
'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
答案 2 :(得分：0)
首先，感谢所有帮助我解决这个问题的人。 我不得不调整建议的解决方案，以使其工作。 请注意，由于它打开源文件和目标文件，因此必须将此宏放入第三个文件中。 遵循代码：
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