我创建了一些代码，使用户可以用4个表填写excelsheet。通过按一个按钮，它将表数据复制到另一个工作簿。它必须找到填充的最后一行，并复制下面的数据。有些单元格不会被填充，所以我使用.Filldown来填充空单元格。为了使.Filldown正常工作，我不得不对表中的行进行计数。
一切正常，但是我是VBA的新手，所以我想知道我的代码是否可以简化。看起来很多代码。
Private Sub CommandButton5_Click()
Dim PassWord As Variant
PassWord = InputBox("Wachtwoord?")
'PassWord = "Something"
If PassWord = "Something" Then
Dim nT1 As Integer
Dim nT2 As Integer
Dim nT3 As Integer
Dim nT4 As Integer
If Sheets("Variabelen").Range("H2") = 0 Then
Set Z = ActiveWorkbook.Sheets(1)
Set T1 = ActiveSheet.ListObjects("Tabel1").DataBodyRange
Set T1C = ActiveSheet.ListObjects("Tabel1")
Set T2 = ActiveSheet.ListObjects("Tabel2").DataBodyRange
Set T2C = ActiveSheet.ListObjects("Tabel2")
Set T3 = ActiveSheet.ListObjects("Tabel3").DataBodyRange
Set T3C = ActiveSheet.ListObjects("Tabel3")
Set T4 = ActiveSheet.ListObjects("Tabel4").DataBodyRange
Set T4C = ActiveSheet.ListObjects("Tabel4")
nT1 = T1C.Range.Rows.Count - 1
nT2 = T2C.Range.Rows.Count - 1
nT3 = T3C.Range.Rows.Count - 1
nT4 = T4C.Range.Rows.Count - 1
'Test_ verwijderen als bestand actief wordt
Set Y = Workbooks.Open("\\Somewhere\Test_Masterbestand Afdeling.xlsx")
'Huidige medewerker in opleiding (T1)
lRow = Y.Worksheets("Data").Cells(Y.Worksheets("Data").Rows.Count, 1).End(xlUp).Row
lRow = lRow + 1
T1.Copy
Y.Worksheets("Data").Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Y.Sheets("Data").Range("I" & lRow).Value = "Huidige medewerker in opleiding"
Y.Sheets("Data").Range("J" & lRow).Value = Z.Range("C3").Value
Y.Sheets("Data").Range("K" & lRow).Value = Z.Range("C4").Value
Y.Sheets("Data").Range("L" & lRow).Value = Z.Range("C6").Value
Dim LastRowA As Long
Dim LastRowB As Long
Dim LastRowC As Long
Dim LastRowD As Long
Dim LastRowE As Long
LastRowA = ActiveSheet.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowB = ActiveSheet.Range("I:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowC = ActiveSheet.Range("J:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowD = ActiveSheet.Range("K:K").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowE = ActiveSheet.Range("L:L").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
CopyrangeB = "I" & LastRowB & ":" & "I" & LastRowA
CopyrangeC = "J" & LastRowC & ":" & "J" & LastRowA
CopyrangeD = "K" & LastRowD & ":" & "K" & LastRowA
CopyrangeE = "L" & LastRowE & ":" & "L" & LastRowA
If nT1 > 1 Then
ActiveSheet.Range(CopyrangeB).FillDown
ActiveSheet.Range(CopyrangeC).FillDown
ActiveSheet.Range(CopyrangeD).FillDown
ActiveSheet.Range(CopyrangeE).FillDown
End If
'Nieuwe instroom in opleiding (T2)
lRow = Y.Worksheets("Data").Cells(Y.Worksheets("Data").Rows.Count, 1).End(xlUp).Row
lRow = lRow + 1
T2.Copy
Y.Worksheets("Data").Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Y.Sheets("Data").Range("I" & lRow).Value = "Nieuwe instroom in opleiding"
Y.Sheets("Data").Range("J" & lRow).Value = Z.Range("C3").Value
Y.Sheets("Data").Range("K" & lRow).Value = Z.Range("C4").Value
Y.Sheets("Data").Range("L" & lRow).Value = Z.Range("C6").Value
Dim LastRowF As Long
Dim LastRowG As Long
Dim LastRowH As Long
Dim LastRowI As Long
Dim LastRowJ As Long
LastRowF = ActiveSheet.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowG = ActiveSheet.Range("I:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowH = ActiveSheet.Range("J:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowI = ActiveSheet.Range("K:K").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowJ = ActiveSheet.Range("L:L").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
CopyrangeG = "I" & LastRowG & ":" & "I" & LastRowF
CopyrangeH = "J" & LastRowH & ":" & "J" & LastRowF
CopyrangeI = "K" & LastRowI & ":" & "K" & LastRowF
CopyrangeJ = "L" & LastRowJ & ":" & "L" & LastRowF
If nT2 > 1 Then
ActiveSheet.Range(CopyrangeG).FillDown
ActiveSheet.Range(CopyrangeH).FillDown
ActiveSheet.Range(CopyrangeI).FillDown
ActiveSheet.Range(CopyrangeJ).FillDown
End If
'Afdelingspecifiek(T3)
lRow = Y.Worksheets("Data").Cells(Y.Worksheets("Data").Rows.Count, 1).End(xlUp).Row
lRow = lRow + 1
T3.Copy
Y.Worksheets("Data").Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Y.Sheets("Data").Range("I" & lRow).Value = "Afdelingspecifiek"
Y.Sheets("Data").Range("J" & lRow).Value = Z.Range("C3").Value
Y.Sheets("Data").Range("K" & lRow).Value = Z.Range("C4").Value
Y.Sheets("Data").Range("L" & lRow).Value = Z.Range("C6").Value
Dim LastRowK As Long
Dim LastRowL As Long
Dim LastRowM As Long
Dim LastRowN As Long
Dim LastRowO As Long
LastRowK = ActiveSheet.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowL = ActiveSheet.Range("I:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowM = ActiveSheet.Range("J:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowN = ActiveSheet.Range("K:K").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowO = ActiveSheet.Range("L:L").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
CopyrangeL = "I" & LastRowL & ":" & "I" & LastRowK
CopyrangeM = "J" & LastRowM & ":" & "J" & LastRowK
CopyrangeN = "K" & LastRowN & ":" & "K" & LastRowK
CopyrangeO = "L" & LastRowO & ":" & "L" & LastRowK
If nT3 > 1 Then
ActiveSheet.Range(CopyrangeL).FillDown
ActiveSheet.Range(CopyrangeM).FillDown
ActiveSheet.Range(CopyrangeN).FillDown
ActiveSheet.Range(CopyrangeO).FillDown
End If
'Individueel (T4)
lRow = Y.Worksheets("Data").Cells(Y.Worksheets("Data").Rows.Count, 1).End(xlUp).Row
lRow = lRow + 1
T4.Copy
Y.Worksheets("Data").Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
Y.Sheets("Data").Range("I" & lRow).Value = "Individueel"
Y.Sheets("Data").Range("J" & lRow).Value = Z.Range("C3").Value
Y.Sheets("Data").Range("K" & lRow).Value = Z.Range("C4").Value
Y.Sheets("Data").Range("L" & lRow).Value = Z.Range("C6").Value
Application.CutCopyMode = False
Dim LastRowP As Long
Dim LastRowQ As Long
Dim LastRowR As Long
Dim LastRowS As Long
Dim LastRowT As Long
LastRowP = ActiveSheet.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowQ = ActiveSheet.Range("I:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowR = ActiveSheet.Range("J:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowS = ActiveSheet.Range("K:K").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowT = ActiveSheet.Range("L:L").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowU = ActiveSheet.Range("N:N").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
CopyrangeQ = "I" & LastRowQ & ":" & "I" & LastRowP
CopyrangeR = "J" & LastRowR & ":" & "J" & LastRowP
CopyrangeS = "K" & LastRowS & ":" & "K" & LastRowP
CopyrangeT = "L" & LastRowT & ":" & "L" & LastRowP
'Formule in Kolom M
CopyrangeU = "N" & LastRowU & ":" & "N" & LastRowP
If nT4 > 1 Then
ActiveSheet.Range(CopyrangeQ).FillDown
ActiveSheet.Range(CopyrangeR).FillDown
ActiveSheet.Range(CopyrangeS).FillDown
ActiveSheet.Range(CopyrangeT).FillDown
ActiveSheet.Range(CopyrangeU).FillDown
End If
' Y.Close (True)
'Quote weghalen bij opleveren
'Sheets("Variabelen").Range("H2").Value = Sheets("Variabelen").Range("H2").Value + 1
Else
MsgBox ("Niet nog een keer Sylvia!!!!")
End If
Else
'Do nothing
End If
End Sub
没有