Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.
Option Explicit
Sub kTest()
Dim wbkActive As Workbook
Dim wbkTemplate As Workbook
Dim dicProID As Object
Dim i As Long, x
Dim strItems As String
Dim Basic, Process
Set wbkActive = ThisWorkbook
Set wbkTemplate = Workbooks.Open(wbkActive.Path & "\Template.xlsx")
With wbkActive.Worksheets("Basic").Range("a1").CurrentRegion
Basic = .Resize(, .Columns.Count + 2).Value2
End With
Process = wbkActive.Worksheets("Process").Range("a1").CurrentRegion
Set dicProID = CreateObject("scripting.dictionary")
dicProID.comparemode = 1
For i = 2 To UBound(Basic, 1)
If Len(Basic(i, 1)) Then
dicProID.Item(Basic(i, 1)) = Array(i, vbNullString)
End If
Next
For i = 2 To UBound(Process, 1)
If dicProID.exists(Process(i, 1)) Then
x = dicProID.Item(Process(i, 1))
strItems = Basic(x(0), 8)
If Len(strItems) Then
Basic(x(0), 7) = Process(i, 5)
Basic(x(0), 8) = Basic(x(0), 8) & vbLf & Process(i, 6) & " - " & Process(i, 7)
dicProID.Item(Process(i, 1)) = Array(x(0), Basic(x(0), 8))
Else
Basic(x(0), 7) = Process(i, 5)
Basic(x(0), 8) = Process(i, 6) & " - " & Process(i, 7)
dicProID.Item(Process(i, 1)) = Array(x(0), Basic(x(0), 8))
End If
End If
Next
If dicProID.Count Then
With wbkTemplate.Worksheets(1)
.UsedRange.ClearContents
.Range("a1").Resize(UBound(Basic, 1), UBound(Basic, 2)) = Basic
.Range("g1:h1") = [{"dori","procid - procn"}]
End With
wbkTemplate.SaveAs Left$(wbkTemplate.Name, InStrRev(wbkTemplate.Name, ".") - 1) & "_" & Format(Now, "mmddyy_hhmm"), 51 '51 - Default, 56 - .xls
wbkTemplate.Close 0
End If
End Sub
Option Explicit
Sub kTest()
Dim wbkTemplate As Workbook
Dim wbkRawData As Workbook
Dim dicProID As Object
Dim i As Long, x
Dim strItems As String
Dim Basic, Process
Set wbkTemplate = ThisWorkbook
Set wbkRawData = Workbooks.Open(wbkTemplate.Path & "\RawData.xlsx")
With wbkRawData.Worksheets("Basic").Range("a1").CurrentRegion
Basic = .Resize(, .Columns.Count + 2).Value2
End With
Process = wbkRawData.Worksheets("Process").Range("a1").CurrentRegion
Set dicProID = CreateObject("scripting.dictionary")
dicProID.comparemode = 1
For i = 2 To UBound(Basic, 1)
If Len(Basic(i, 1)) Then
dicProID.Item(Basic(i, 1)) = Array(i, vbNullString)
End If
Next
For i = 2 To UBound(Process, 1)
If dicProID.exists(Process(i, 1)) Then
x = dicProID.Item(Process(i, 1))
strItems = Basic(x(0), 8)
If Len(strItems) Then
Basic(x(0), 7) = Process(i, 5)
Basic(x(0), 8) = Basic(x(0), 8) & vbLf & Process(i, 6) & " - " & Process(i, 7)
dicProID.Item(Process(i, 1)) = Array(x(0), Basic(x(0), 8))
Else
Basic(x(0), 7) = Process(i, 5)
Basic(x(0), 8) = Process(i, 6) & " - " & Process(i, 7)
dicProID.Item(Process(i, 1)) = Array(x(0), Basic(x(0), 8))
End If
End If
Next
If dicProID.Count Then
With wbkTemplate.Worksheets(1)
.UsedRange.ClearContents
.Range("a1").Resize(UBound(Basic, 1), UBound(Basic, 2)) = Basic
.Range("g1:h1") = [{"dori","procid - procn"}]
End With
wbkTemplate.Worksheets(1).Copy
ActiveWorkbook.SaveAs wbkTemplate.Path & "\" & Left$(wbkTemplate.Name, InStrRev(wbkTemplate.Name, ".") - 1) & "_" & Format(Now, "mmddyy_hhmm"), 51 '51 - Default, 56 - .xls
ActiveWorkbook.Close 0
wbkRawData.Close 0
Set wbkRawData = Nothing
End If
End Sub
Template.xlsm