求助！如何把横向表格的数据提前到窗口式表格中

msnmurong

gwjkkkkk 发表于 2022-12-4 20:18
代码审核中，请楼主参考附件。。。

老师 ,这代码后面可以加注解吗。我想学习下。
如果表一添加了新的字段,怎么修改才能一起调用呢。

msnmurong

gwjkkkkk 发表于 2022-12-5 16:51
有数了，回家帮你弄一下。。。

能不能拜你为师。

msnmurong

gwjkkkkk 发表于 2022-12-5 16:51
有数了，回家帮你弄一下。。。

大神,还想弄一个按钮,可以在调用后,一键另存为以机房名称作为文件名的新文件。比如B1:G91区域。或者新建一个sheet,把sheetA列出现的机房名称先调用,然后在自动另存为新文件。全程自动。

gwjkkkkk

Sub TEST5()
    Dim arr, i&, dic As Object, iPosRow&
    Dim strFileName$, strPath$, shp As Shape
    Dim strFirstAddress$, Rng As Range, rngFind As Range
    Set dic = CreateObject("Scripting.Dictionary")
    If [B1] = "" Then MsgBox "查询数据为空，请检查！", vbExclamation: Exit Sub
    arr = Sheets(2).[A1].CurrentRegion
    For i = 2 To UBound(arr)
       If Not dic.exists(arr(i, 4)) Then
          dic(arr(i, 4)) = Array(CDate(arr(i, 2)), i) '如字典中不存查询数据，则i对数据进行行定位，你的日期为文本，不能进行比对，故转成日期格式
          Else
            If CDate(arr(i, 2)) > dic(arr(i, 4))(0) Then '如字典已存在，则对日期进行判断，如果日期大于则对字典中日期键值则重新赋值，并重新定位列位置
               dic(arr(i, 4)) = Array(CDate(arr(i, 2)), i)
            End If
       End If
    Next i
    If Not dic.exists([B1].Value) Then MsgBox "找不到站点,请新增！", vbExclamation: Exit Sub '如果不存在键值则说明查询数据无，进行提示并退出。
    Application.ScreenUpdating = False
    iPosRow& = dic([B1].Value)(1) '将存在的站定，在arr中定位列号并赋值给iposrow
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & [B1].Value '提前定义好需要保存的文件名
    ThisWorkbook.Sheets(1).Copy '将当前第1个工作表拷贝成新工作簿
    Set Rng = [A3:F100] '设置查询范围，请自行调整
    For i = 1 To UBound(arr, 2) '对第一行数据进行循环查询
        Set rngFind = Rng.Find(arr(1, i), , , xlWhole) '全部相同方式进行匹配
        If Not rngFind Is Nothing Then
          strFirstAddress = rngFind.Address
          Do
            rngFind.Offset(, 1) = arr(iPosRow, i) '循环方式查找，直到没有为止
            Set rngFind = Rng.FindNext(rngFind)
          Loop Until rngFind.Address = strFirstAddress
        End If
    Next i
    For Each shp In ActiveSheet.Shapes '将工作簿按钮删除
       shp.Delete
    Next
    ActiveWorkbook.SaveAs strFileName '以机房名称将当前工作簿保存
    ActiveWorkbook.Close '关闭工作簿
    Set dic = Nothing
    Application.ScreenUpdating = True
    MsgBox "文件生成完成！", 64
End Sub

gwjkkkkk

代码审核中，请参考附件，写代码还好，注解写起来比较麻烦，请参考附件。。。

gwjkkkkk

msnmurong 发表于 2022-12-5 17:08
老师 ,这代码后面可以加注解吗。我想学习下。
如果表一添加了新的字段,怎么修改才能一起调用呢。

添加新字段，只要连续的在第2个工作表第1行，则自动读取，不需要考虑。。。

msnmurong

gwjkkkkk 发表于 2022-12-5 19:10
Sub TEST5()
    Dim arr, i&, dic As Object, iPosRow&
    Dim strFileName$, strPath$, shp As Shape
...

arr = Sheets(2).[A1].CurrentRegion
这个A1不理解,我改成A2,A3,A4好像都能正常运行。

msnmurong

gwjkkkkk 发表于 2022-12-5 19:10
Sub TEST5()
    Dim arr, i&, dic As Object, iPosRow&
    Dim strFileName$, strPath$, shp As Shape
...

Set Rng = [A3:F100] '设置查询范围，请自行调整
这个A3:F100实际导出来的表格包含A1的。
我想单独设计一个 功能,就是只是导出的。要怎么把这段代码分开呢。
或者我想取表格中的3个单元格的数据 ,再加上我特定的文字,比如 PD699-紫晶苑-一站一档作为文件名。

gwjkkkkk

msnmurong 发表于 2022-12-6 12:27
arr = Sheets(2).[A1].CurrentRegion
这个A1不理解,我改成A2,A3,A4好像都能正常运行。

根据你的表格，是一样的，可参照currentregion概念你就知道了。。。

msnmurong

gwjkkkkk 发表于 2022-12-6 14:02
根据你的表格，是一样的，可参照currentregion概念你就知道了。。。

当前活动区域。