Question

请帮助-我在这里找到了以下代码，它可以正常工作。但是，目前它会将整行复制到特定的工作表中-我希望它将特定的列从一个工作表复制到另一个工作表的特定列中。

例如，我有一个带有第1周，第2周，第3周等标签的电子表格我希望宏进入并将源工作表标签第1周的A，F，H列复制到第1周的电子表格标签中的B，G和I，然后循环第2周和第3周，依此类推

希望这是有道理的-任何帮助将不胜感激

Sub Consolidate()
Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet

'Setup
Application.ScreenUpdating = False  'speed up macro 
execution
Application.EnableEvents = False    'turn off other macros 
for now
Application.DisplayAlerts = False   'turn off system 
messages for now

Set wsMaster = ThisWorkbook.Sheets("Month End Summary")    
'sheet report is built into

With wsMaster
If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
    .UsedRange.Offset(8).EntireRow.Clear
    NR = 9
Else
    NR = .Range("A" & .rows.Count).End(xlUp).Row + 1    
'appends data to existing data
End If

'Path and filename (edit this section to suit)

   MsgBox "Please select a folder with files to consolidate"
Do
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\2010\Test\"
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then
            fPath = .SelectedItems(1) & "\"
            Exit Do
        Else
            If MsgBox("No folder chose, do you wish to 
abort?", _
                vbYesNo) = vbYes Then Exit Sub
        End If
    End With
Loop

fPathDone = fPath & "Imported\"     'remember final \ in 
this string
On Error Resume Next
    MkDir fPathDone                 'creates the completed 
folder if missing
On Error GoTo 0
fName = Dir(fPath & "*.xls*")       'listing of desired 
files, edit filter as desired

'Import a sheet from found files
Do While Len(fName) > 0
    If fName <> ThisWorkbook.Name Then              'don't 
reopen this file accidentally
        Set wbData = Workbooks.Open(fPath & fName)  'Open 
file
    'This is the section to customize, replace with your own 
action code as needed

      Dim ws As Worksheet
For Each ws In wbData.Sheets(Array("Month End Summary"))
    LR = ws.Range("B" & ws.rows.Count).End(xlUp).Row 'Find 
last row
    If NR = 1 Then 'copy the data AND titles
        ws.Range("A9:A" & LR).EntireRow.Copy .Range("A" & 
NR)
    Else 'copy the data only
        ws.Range("A9:A" & LR).EntireRow.Copy .Range("A" & 
NR)
    End If
    NR = .Range("A" & .rows.Count).End(xlUp).Row + 1 'Next 
row
Next ws
        wbData.Close False                                
'close file
        Name fPath & fName As fPathDone & fName           
'move file to IMPORTED folder
    End If
    fName = Dir                                       'ready 
next filename
Loop
End With


ErrorExit:    'Cleanup
ActiveSheet.Columns.AutoFit
Application.DisplayAlerts = True         'turn system alerts 
back on
Application.EnableEvents = True          'turn other macros 
back on
Application.ScreenUpdating = True        'refreshes the 
screen

End Sub

Answer 1

尝试一下：

Sub CopyColumns()
    Dim Source As Workbook, Target As Workbook, sht As Worksheet

    Set Source = Workbooks("Source")
    Set Target = Workbooks("Target")

    For Each sht In Source.Sheets
        sht.Range("A1").EntireColumn.Copy Destination:=Target.Worksheets(sht.Name).Range("B1").EntireColumn
        sht.Range("F1").EntireColumn.Copy Destination:=Target.Worksheets(sht.Name).Range("G1").EntireColumn
        sht.Range("H1").EntireColumn.Copy Destination:=Target.Worksheets(sht.Name).Range("I1").EntireColumn
    Next sht
End Sub

一些注意事项：

假设您有两个打开工作簿：Source和Target
假设工作表名称在每个工作簿中均完全相同

VBA将某些列复制到特定工作表

1 个答案: