Excel & VBA

• M

  AI终于要取代精算师了？？Excel公式解释，VBA自动编写神器
  2023年12月25日 03:31 • Mengkelyu   2023年12月25日 04:28

  7
  0
  赞同
  7
  帖子
  9
  浏览

  M 2023年12月25日 04:28

  解释公式：
• M

  如何在Excel中使用ChatGPT
  2023年12月24日 05:12 • Mengkelyu   2023年12月24日 05:23

  3
  0
  赞同
  3
  帖子
  7
  浏览

  M 2023年12月24日 05:23

  代码部分 Option Explicit Const key = "your key" # 这里写入我们在准备工作中拿到的API Key Sub SendQuestionToGPT3() 'Declare variables Dim request As Object Dim response As String Dim API As String API = key #这里我们把问题放到了B3里面 Dim question As String question = """" & Range("B3").Value & """" #创建HTTP request Set request = CreateObject("MSXML2.XMLHTTP") #设置HTTP 请求 request.Open "POST", "https://api.chatanywhere.com.cn/v1/chat/completions", False request.setRequestHeader "Content-Type", "application/json" request.setRequestHeader "Authorization", "Bearer " & API request.send "{""model"": ""gpt-3.5-turbo"",""messages"": [{""role"": ""user"", ""content"": " & question & "}],""temperature"": 0.7 }" #解析返回值，这里用到了我们刚刚import进去的library response = request.responseText response = Replace(response, "[{", "{") response = Replace(response, "}]", "}") Dim ParsedResponse As Object Set ParsedResponse = JsonConverter.ParseJson(response) #把返回的答案输入到excel里面 Range("B6").Value = ParsedResponse("choices")("message")("content") 'Clean up the object Set request = Nothing End Sub
• M

  IBNR计算(Chain Ladder方法) 实用VBA -- 选择 左上三角 / 右下三角范围
  2021年10月14日 11:05 • Mengkelyu   2023年5月28日 10:10

  4
  0
  赞同
  4
  帖子
  26
  浏览

  M 2023年5月28日 10:10

  可以利用GetSubtractRng这个计算差集的函数来得到右下角三角形的范围 Function GetSubtractRng(r1 As Range, r2 As Range) Dim r As Range, r3 As Range For Each r In r1 If Intersect(r, r2) Is Nothing Then If r3 Is Nothing Then Set r3 = r Else Set r3 = Union(r, r3) End If End If Next Set GetSubtractRng = r3 End Function Sub RBTriangle() Dim row As Integer Dim col As Integer row = Selection.Rows.Count col = Selection.Columns.Count Dim rg As Range Dim targetRg As Range Dim i As Integer Set rg = Selection.Resize(row, 1) Set targetRg = Selection.Resize(row, 1) For i = 1 To col - 1 If row - i > 0 Then Set targetRg = Union(targetRg, rg.Offset(0, i).Resize(row - i, 1)) Next i Set targetRg = GetSubtractRng(Selection, targetRg) targetRg.Select End Sub
• M

  如何把Workbook中的Formula都存成值
  2023年3月10日 11:32 • Mengkelyu   2023年3月10日 11:32

  1
  0
  赞同
  1
  帖子
  3
  浏览

  尚无回复

• M

  VBA 常见快捷键，Windows VS Mac
  2022年12月11日 06:54 • Mengkelyu   2022年12月11日 06:54

  1
  0
  赞同
  1
  帖子
  8
  浏览

  尚无回复

• M

  如何快速比较两个工作薄的不同
  2022年3月18日 13:08 • Mengkelyu   2022年12月7日 04:02

  4
  0
  赞同
  4
  帖子
  23
  浏览

  M 2022年12月7日 04:02

  @Mengkelyu 注意到这个代码在工作簿中有公式或数字错误时会报 "type Mismatch"的错误。 可以在代码开头加入 On Error Resume Next 来跳过这些错误，继续运行代码。
• M

  VBA字符串模糊匹配 Version 2 （支持中文)
  2022年11月26日 17:22 • Mengkelyu   2022年11月26日 17:22

  1
  0
  赞同
  1
  帖子
  9
  浏览

  尚无回复

• M

  如何用VBA做一个Weekly的Email Alert
  2022年9月4日 07:09 • Mengkelyu   2022年9月4日 07:55

  5
  0
  赞同
  5
  帖子
  6
  浏览

  M 2022年9月4日 07:55

  Email reminder public.zip
• Y

  如何在Task Allocation环节用VBA实现自动更新
  2022年6月28日 13:31 • yrongyyf   2022年6月28日 14:46

  3
  0
  赞同
  3
  帖子
  18
  浏览

  M 2022年6月28日 14:46

  1656423090374-示例数据.zip
• M

  用VBA抽取一个文件夹中所有Excel并合并成一个Sheet
  2022年6月23日 05:28 • Mengkelyu   2022年6月23日 15:22

  4
  0
  赞同
  4
  帖子
  14
  浏览

  M 2022年6月23日 15:22

  第一步我们要把这个读入工作表名和读出工作表名的map读入宏。可以这么写。这里是选择了Parameters这个工作表里面"A1"按住Ctrl+A选中的区域，并通过Offset向下移一格，然后用resize减少一行；这样可以去掉读入的表标题。 Dim mapping As Variant With ThisWorkbook.Worksheets("Parameters").Range("A1").CurrentRegion mapping = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value End With 那么我们就把下面这个表储存到mapping这个变量里面啦 然后我们定义一个变量用来储存每个读出的数据总数，这里我们需要三组变量；因此这应该是一个有三个数字的数组。 Dim cntrows As Variant ReDim cntrows(UBound(mapping, 1)) 最后一步就是循环每个工作薄里面的每个工作表，如果这个工作表名能和Map里面的第一列任意一个匹配，那么它就会被输出到Map里面第二列对应的工作表内。 For Each st In wbResults.Worksheets For i = 1 To UBound(mapping, 1) If st.Name = mapping(i, 1) Then rng = st.UsedRange.Value ThisWorkbook.Worksheets(mapping(i, 2)).Range("A1").Offset(cntrows(i), 0).Resize(UBound(rng, 1), UBound(rng, 2)).Value = rng cntrows(i) = cntrows(i) + UBound(rng, 1) End If Next i 完整代码 Sub Copyfrom_all_excel_files_in_folder() Dim FoldPath As String Dim DialogBox As FileDialog Dim FileOpen As String Dim rng As Variant On Error Resume Next Set DialogBox = Application.FileDialog(msoFileDialogFolderPicker) If DialogBox.Show = -1 Then FoldPath = DialogBox.SelectedItems(1) End If Application.ScreenUpdating = False Application.DisplayAlerts = False 'read the mapping to the macro Dim mapping As Variant With ThisWorkbook.Worksheets("Parameters").Range("A1").CurrentRegion mapping = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value End With Dim cntrows As Variant ReDim cntrows(UBound(mapping, 1)) Dim i As Integer ' If the output sheet does not exist create it For i = 1 To UBound(mapping, 2) If WorksheetExists(mapping(i, 2)) = False Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = mapping(i, 2) Next i On Error GoTo 0 If FoldPath = "" Then Exit Sub FileOpen = Dir(FoldPath & "\*.xls*") Do While FileOpen <> "" Set wbResults = Workbooks.Open(FoldPath & "\" & FileOpen, UpdateLinks:=0, ReadOnly:=True) For Each st In wbResults.Worksheets For i = 1 To UBound(mapping, 1) If st.Name = mapping(i, 1) Then rng = st.UsedRange.Value ThisWorkbook.Worksheets(mapping(i, 2)).Range("A1").Offset(cntrows(i), 0).Resize(UBound(rng, 1), UBound(rng, 2)).Value = rng cntrows(i) = cntrows(i) + UBound(rng, 1) End If Next i Next wbResults.Close FileOpen = Dir Loop Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Function WorksheetExists(ByVal shtName As String, Optional ByVal wb As Workbook) As Boolean Dim sht As Worksheet If wb Is Nothing Then Set wb = ThisWorkbook On Error Resume Next Set sht = wb.Sheets(shtName) On Error GoTo 0 WorksheetExists = Not sht Is Nothing End Function Copy_to_excel - V2.zip
• M

  常用VBA集锦（更新）
  2020年7月1日 16:18 • Mengkelyu   2022年6月21日 14:43

  6
  0
  赞同
  6
  帖子
  112
  浏览

  M 2022年6月21日 14:43

  打开一个文件夹内所有工作表 Sub Open_all_excel_files_in_folder() Dim FoldPath As String Dim DialogBox As FileDialog Dim FileOpen As String On Error Resume Next Set DialogBox = Application.FileDialog(msoFileDialogFolderPicker) If DialogBox.Show = -1 Then FoldPath = DialogBox.SelectedItems(1) End If If FoldPath = "" Then Exit Sub FileOpen = Dir(FoldPath & "\*.xls*") Do While FileOpen <> "" Workbooks.Open FoldPath & "\" & FileOpen FileOpen = Dir Loop End Sub
• K

  提问：如何调用Shell语句解压.gz文件
  2022年5月26日 03:07 • Kea_Zhang   2022年5月27日 05:10

  2
  0
  赞同
  2
  帖子
  12
  浏览

  M 2022年5月27日 05:10

  可以尝试 tar -xvzf 需要解压的文件路径
• M

  如何用VBScript自动化VBA运行
  2022年4月24日 10:49 • Mengkelyu   2022年4月24日 11:11

  3
  0
  赞同
  3
  帖子
  6
  浏览

  M 2022年4月24日 11:11

  有一个小的优化，可以像下面这样修改代码，运行过程就会储存在系统日志里面 Sub Automation(path, macro) Set objExcel = CreateObject("Excel.Application") Set objWorkbook = objExcel.Workbooks.Open(path) objExcel.Application.Visible = False objExcel.Application.Run macro objExcel.ActiveWorkbook.save objExcel.ActiveWorkbook.Close objExcel.Application.Quit End Sub Dim shl Set shl = CreateObject("WScript.Shell") Call Automation("C:\MengkeLyu\automation\test3.xlsm", "test3.xlsm!main") Call shl.LogEvent(0,"Test3 has been finished") Call Automation("C:\MengkeLyu\automation\test4.xlsm", "test4.xlsm!main") Call shl.LogEvent(0,"Test4 has been finished") Call Automation("C:\MengkeLyu\automation\test5.xlsm", "test5.xlsm!main") Call shl.LogEvent(0,"Test5 has been finished") Set shl = Nothing WScript.Echo "Finished." WScript.Quit 然后我们打开系统日志，搜索Event Viewer Windows logs里面找到Application 点进来找到WSH，General里面就会是我们自己写的log
• M

  如何简单破解VBA宏密码 -- Excel没有秘密系列
  2022年2月20日 03:55 • Mengkelyu   2022年2月20日 03:59

  3
  0
  赞同
  3
  帖子
  7
  浏览

  M 2022年2月20日 03:59

  然后每一个Module里面有什么代码就都可以打印出来啦
• M

  规划模型运行工具 -- VBA Scheduled Run
  2022年2月19日 07:45 • Mengkelyu   2022年2月19日 08:13

  8
  0
  赞同
  8
  帖子
  11
  浏览

  M 2022年2月19日 08:13

  2.点击Run as Scheduled 控件发生的事件 （代码看不全可以左右上下滑动） '这个控件我起的名字是Run Private Sub Run_Click() ‘Error handling On Error Resume Next Dim wb As Workbook Application.ScreenUpdating = False '如果第一个Listbox不是空值 If ListBox1.Value <> "" Then '在Excel屏幕左下方告诉用户第一个宏正在跑 Application.StatusBar = "Your first task is running" '跑这个宏 Application.Run "'" + TextBox1.Value + "'!" + ListBox1.Value Set wb = Workbooks.Open(TextBox1.Value) '关掉打开的工作簿 wb.Close SaveChanges:=False ’第二第三个task同理 If ListBox2.Value <> "" Then Application.StatusBar = "Your second task is running" Application.Run "'" + TextBox2.Value + "'!" + ListBox2.Value Set wb = Workbooks.Open(TextBox2.Value) wb.Close SaveChanges:=False End If If ListBox3.Value <> "" Then Application.StatusBar = "Your third task is running" Application.Run "'" + TextBox3.Value + "'!" + ListBox3.Value Set wb = Workbooks.Open(TextBox3.Value) wb.Close SaveChanges:=False End If Else MsgBox "Please input the macro you want to schedule ;D" End If Application.ScreenUpdating = True If Err.Description = "" Then MsgBox "Successfully run" Else MsgBox "Please note the following error message in running your code: " + Err.Description End If End Sub
• M

  用VBA Dictionary做一个简单的用户系统
  2022年2月13日 07:21 • Mengkelyu   2022年2月13日 08:16

  4
  0
  赞同
  4
  帖子
  9
  浏览

  M 2022年2月13日 08:16

  然后给我们的按钮赋予宏 点击注册 点击登入 因为这个密码对大小写敏感，提示密码错误
• M

  如何解决VBA Event中不能调用另一个Worksheet中命名范围的情况
  2022年1月23日 06:43 • Mengkelyu   2022年1月23日 06:43

  1
  0
  赞同
  1
  帖子
  3
  浏览

  尚无回复

• M

  用VBA模拟外星人入侵
  2022年1月15日 14:08 • Mengkelyu   2022年1月15日 14:19

  3
  0
  赞同
  3
  帖子
  4
  浏览

  M 2022年1月15日 14:19

  excel在这里 Replicator.zip
• M

  如何用VBA表白系列2：一个把黑线涂黄的游戏
  2022年1月2日 05:43 • Mengkelyu   2022年1月2日 06:05

  4
  0
  赞同
  4
  帖子
  8
  浏览

  M 2022年1月2日 06:05

  源文件放到这里了，你们拿去玩吧。 Love - for intro.zip
• M

  提问：如何用VBA处理脏数据
  2021年12月22日 13:56 • Mengkelyu   2021年12月22日 13:56

  1
  0
  赞同
  1
  帖子
  6
  浏览

  尚无回复