Question

我正在尝试使用VBA宏在Excel工作表中编写。在我打开工作簿后：

Set wrk=open ("C:/text.xlsx")

我在列“B”中找到最后一个非空单元格，例如：

LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row

然后我写了一个：

cell(LastRow,2) =1

但是当我想以同样的方式写在“D”栏中时：

LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
cell(lastRow,4)=1

宏在第一行中写入一行，知道列“B”和列“D”中的最后一个非空单元格不相同。

我写道：

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False

在打开Excel工作表之前使宏更快。

mycode的：

Option Explicit
Private Sub maac() ' fonction de décharge de questionnaire type Compostage

Dim src_path, distination_Path As String
Dim source, distination As String 'workbooks
Dim src_feuil, via, distination_feuil As String 'sheets
Dim src_cell_address As String ' adresses
Dim count, countB, last_via_cell, distination_col_address As Integer
Dim last_dist_row As Long
Dim dist_path_fname As String
Dim co, wrk As Workbook

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False

'Desactive les alerts et les mises à jour écran
'App_prop.app_disable
 Set co = ThisWorkbook
 via = ActiveSheet.Name 'activated Via worksheet
last_via_cell = Sheets(via).UsedRange.Rows.count
'MsgBox ActiveSheet.Name ' nom de la feuil active
'MsgBox Sheets(via).Cells(1, 1).Address(RowAbsolute:=False,     ColumnAbsolute:=False)

src_path = Sheets(via).Cells(2, 1).Value
source = "src.xlsx"
src_feuil = Sheets(via).Cells(2, 3).Value
src_cell_address = Sheets(via).Cells(Sheets(via).Cells(2, 6).Value, Sheets(via).Cells(2, 7).Value).Address

distination_Path = Sheets(via).Cells(2, 9) ' path of source file (questionnaire) bdd file path
distination = Sheets(via).Cells(2, 8)  ' name of bdd file
distination_feuil = Sheets(via).Cells(2, 10) ' name of sheet of bdd file
distination_col_address = Sheets(via).Cells(2, 12)

'DoEvents

Set wrk = Workbooks.Open(distination_Path & "\" & distination & ".xlsx")
'Application.ScreenUpdating = False
last_dist_row = wrk.Sheets(distination_feuil).Cells(Rows.count,  distination_col_address).End(xlUp).Row + 1
MsgBox last_dist_row
wrk.Sheets(distination_feuil).Cells(last_dist_row, distination_col_address) = GetValue(src_path, source, src_feuil, src_cell_address) 'GET VALUE


For count = 3 To last_via_cell

'---- SOURCE COORDINATIONS
'Workbooks("C:\Users\pc\Desktop\comp.xlsm").Sheets("Compostage").Activate
src_path = co.Sheets(via).Cells(count, 1) ' path of source file (questionnaire)
 source = "src.xlsx" ' name of source file (questionnaire)
src_feuil = co.Sheets(via).Cells(count, 3) ' name of source file sheet (questionnaire)
src_cell_address = co.Sheets(via).Cells(co.Sheets(via).Cells(count, 6).Value, co.Sheets(via).Cells(count, 7).Value).Address

'----- BDD COORDINATIONS
distination_Path = co.Sheets(via).Cells(count, 9) ' path of source file (questionnaire) 'bdd file path
distination = co.Sheets(via).Cells(count, 8)  ' name of bdd file
distination_feuil = co.Sheets(via).Cells(count, 10) ' name of sheet of bdd file
distination_col_address = co.Sheets(via).Cells(count, 12)
MsgBox "col" & distination_col_address


If co.Sheets(via).Cells(count, 8) <> co.Sheets(via).Cells(count - 1, 8) Then
wrk.Save
wrk.Close
Set wrk = Nothing
Set wrk = Workbooks.Open(distination_Path & "\" & distination & ".xlsx")
last_dist_row = wrk.Sheets(distination_feuil).Cells(Rows.count,   distination_col_address).End(xlUp).Row + 1 ' get the last empty row in BDD
'MsgBox "row" & last_dist_row
wrk.Sheets(distination_feuil).Cells(last_dist_row, distination_col_address) = GetValue(src_path, source, src_feuil, src_cell_address) 'get value
Else
'--------------------------OPEN
'last_dist_row =wrk.Sheets(distination_feuil).Range("A1").End(xlDown).Row + 1  get the last empty row in BDD
last_dist_row = wrk.Sheets(distination_feuil).Cells(Rows.count, distination_col_address).End(xlUp).Row + 1
wrk.Sheets(distination_feuil).Cells(last_dist_row, distination_col_address) =    GetValue(src_path, source, src_feuil, src_cell_address) 'GET VALUE
End If
Next count
wrk.Save
wrk.Close
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
End Sub
Private Function GetValue(path, file, sheet, ref)
  'Retrieves a value from a closed workbook
    Dim arg As String
'   Make sure the file exists
    If Right(path, 1) <> "\" Then path = path & "\"
    If Dir(path & file) = "" Then
        GetValue = "File Not Found"
        Exit Function
    End If
'   Create the argument
    arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
      Range(ref).Range("A1").Address(, , xlR1C1)
'   Execute an XLM macro
If ExecuteExcel4Macro(arg) = 0 Then
    GetValue = ""
    Else: GetValue = ExecuteExcel4Macro(arg)
    End If
End Function

动态更新列VBA Excel中的最后一个非空单元格

0 个答案: