来娘家求助EXCEL大佬

查看相关话题
AhmedL-avatar

AhmedL

2021-01-26T02:26:18+00:00

小弟最近需要对一个EXCEL进行拆分。把表头和每行的数据以新的EXCEL文件保存，找度娘询问些信息后，最后通过网友分享的VB代码完成了需求。
效果见下面三张图：
[img]https://img.nga.178.com/attachments/mon_202102/01/-7Qbip3-i0daK1gT3cSpo-am.jpg.thumb.jpg[/img]
[img]https://img.nga.178.com/attachments/mon_202102/01/-7Qbip3-5hqlK16T1kS9i-yg.jpg.thumb.jpg[/img]
[img]https://img.nga.178.com/attachments/mon_202102/01/-7Qbip3-4u8zK1sT3cSsg-gw.jpg.thumb.jpg[/img]

但是现在遇到了一个新的问题，见下图
[img]https://img.nga.178.com/attachments/mon_202102/01/-7Q5t6o-j84fK1qT3cSo2-bq.jpg.thumb.jpg[/img]
里面的学校C实际包含了两行数据，之前用的VB代码完成不了这个操作。因为不会写代码，也看不懂代码，只能来娘家求助了，谢谢大家！
附上原来用的代码：
Sub SplitExl()
Application.DisplayAlerts = False '新建的文档存在时，不发送警示，覆盖式保存
Dim lngRs&, lngCs&, cx&, strEndCl$
Dim topR(), EveryR(), oExl As Object, oWk As Workbook
Dim strPath$
strPath = ThisWorkbook.Path & "\"
With ActiveSheet.UsedRange
lngRs = .Rows.Count
lngCs = .Columns.Count
End With
strEndCl = Replace(Replace(Cells(1, lngCs).Address, "$", ""), "1", "")
topR = Range("A1:" & strEndCl & "1") '数据标题行
For cx = 2 To lngRs
EveryR = Range("A" & Format(cx) & ":" & strEndCl & Format(cx)) '把每行记录放入数组
Set oWk = Application.Workbooks.Add
With oWk
'.Parent.Visible = True
With .Sheets(1)
.Range("A1:" & strEndCl & "1") = topR '把标题行放入另建的工作薄
.Range("A2:" & strEndCl & "2") = EveryR '把单个记录放入同一另建的工作薄
End With
.SaveAs Filename:=strPath & EveryR(1, 1) & ".xls" '以每行A列记录为工作薄名称
.Close
End With
Next
Set oWk = Nothing
Set oExl = Nothing
Erase topR: Erase EveryR
Application.DisplayAlerts = True
End Sub
YoDatsToxic-avatar

YoDatsToxic

[img]https://img.nga.178.com/attachments/mon_202102/01/-7Qbip4-cvbkKcT1kSbp-5u.png[/img]
Cupido 💘-avatar

Cupido 💘

我的vba跟王佩丰学的
你这个代码 我得看很久才能看懂
爱莫能助了
MrPsycho-avatar

MrPsycho

[quote][pid=489806895,25359716,1]Reply[/pid] Post by [uid=37787397]云南段正淳[/uid] (2021-02-01 10:36):

我的vba跟王佩丰学的
你这个代码 我得看很久才能看懂
爱莫能助了[/quote]我也是看的他的课程 这个人讲课真的不错
AhmedL-avatar

AhmedL

Reply to [pid=489806276,25359716,1]Reply[/pid] Post by [uid=36660660]隔壁家小王[/uid] (2021-02-01 10:34)
老哥这个是WPS吗？
YoDatsToxic-avatar

YoDatsToxic

[quote][pid=489809393,25359716,1]Reply[/pid] Post by [uid=1897402]汏灰狼[/uid] (2021-02-01 10:44):

老哥这个是WPS吗？[/quote]wps 每天打卡白嫖会员
Khalif-avatar

Khalif

exceL自带的：
数据-获取数据-自文件夹
对不起看错了。
GOD HIMSELF-avatar

GOD HIMSELF

合并单元格除了第一格以外都是空值
FewShots-avatar

FewShots

For i = 1 To ActiveSheet.Range("a65536").End(xlUp).Row
If Range("a" & i).MergeCells = True Then
Range("a" & i).UnMerge
Range("a" & i + 1) = Range("a" & i)


End If
Next

把这段代码放到[img]https://img.nga.178.com/attachments/mon_202102/01/-7Q8fp2-a7aeK15T3cSi0-aa.jpg.thumb.jpg[/img]
AhmedL-avatar

AhmedL

Reply to [pid=489810700,25359716,1]Reply[/pid] Post by [uid=41755616]下学上达呀[/uid] (2021-02-01 10:48)
YoDatsToxic-avatar

YoDatsToxic

既然都已经学到vba了，合并单元格这个坏习惯还是尽早改掉吧。
[img]https://img.nga.178.com/attachments/mon_202102/01/-7Q8fp2-2oqkKbT1kSey-95.png[/img]
AhmedL-avatar

AhmedL

Reply to [pid=489812827,25359716,1]Reply[/pid] Post by [uid=1897402]汏灰狼[/uid] (2021-02-01 10:54)
没事的，也学了一招，估计以后也能用到，谢谢
Sin Stalker-avatar

Sin Stalker

为什么不用派森呢
Sin Stalker-avatar

Sin Stalker

ffill方法直接解决，还可以求和
AhmedL-avatar

AhmedL

Reply to [pid=489813819,25359716,1]Reply[/pid] Post by [uid=42603367]奴隶骑士盖提亚[/uid] (2021-02-01 10:57)
小弟不才，不会派森[s:ac:哭]
AhmedL-avatar

AhmedL

Reply to [pid=489811616,25359716,1]Reply[/pid] Post by [uid=1754443]华麗麗[/uid] (2021-02-01 10:50)
谢谢大佬。可能我没有表达我的需求，因为表格是别人给到我的，我要做的就是拆分，所以我所希望的需求是这样的，见下图
[img]https://img.nga.178.com/attachments/mon_202102/01/-7Q5tt3-emy9KyT3cSr9-7m.jpg.thumb.jpg[/img]
加入了大佬的代码后，实现的效果是这样的，见下图
[img]https://img.nga.178.com/attachments/mon_202102/01/-7Qsao6-83rlKpT3cSox-5w.jpg.thumb.jpg[/img]
麻烦大佬再帮忙看看，谢谢
AhmedL-avatar

AhmedL

Reply to [pid=489812874,25359716,1]Reply[/pid] Post by [uid=36660660]隔壁家小王[/uid] (2021-02-01 10:54)
其实平时用到EXCEL的机会不大，我主要做的都是文案工作，EXCEL更多的时候是作为一个排表格的工具。
谢谢推荐的课程和建议，争取能把EXCEL用的更像是EXCEL[s:ac:上]
FewShots-avatar

FewShots

Reply to [pid=489816784,25359716,1]Reply[/pid] Post by [uid=1897402]汏灰狼[/uid] (2021-02-01 11:06)
那这种情况，你整个代码都需要改了。

其实改代码真不如让人重新写一个来得快。
LanderosLol-avatar

LanderosLol

Sub SplitExl()
Application.DisplayAlerts = False '新建的文档存在时，不发送警示，覆盖式保存
Dim lngRs&, lngCs&, cx&, strEndCl$
Dim topR(), EveryR(), oExl As Object, oWk As Workbook
Dim strPath$
dim Temp_Name$,Temp_Row&


strPath = ThisWorkbook.Path & "\"
With ActiveSheet.UsedRange
lngRs = .Rows.Count
lngCs = .Columns.Count
End With

Temp_Name=""

strEndCl = Replace(Replace(Cells(1, lngCs).Address, "$", ""), "1", "")
topR = Range("A1:" & strEndCl & "1") '数据标题行
For cx = 2 To lngRs
EveryR = Range("A" & Format(cx) & ":" & strEndCl & Format(cx)) '把每行记录放入数组

if EveryR(1,1).Value<>"" then
EveryR(1,1).Value=Temp_Name
Temp_Row=2
Set oWk = Application.Workbooks.Add
else
Temp_Row=Temp_Row+1
Set oWk = Workbooks.Open(strPath & Temp_Name & ".xls")
end if

Set oWk = Application.Workbooks.Add
With oWk
'.Parent.Visible = True
With .Sheets(1)
.Range("A1:" & strEndCl & "1") = topR '把标题行放入另建的工作薄
.Range("A" & Temp_Row &":" & strEndCl & Temp_Row) = EveryR '把单个记录放入同一另建的工作薄
End With
.SaveAs Filename:=strPath & Temp_Name & ".xls" '以每行A列记录为工作薄名称
.Close
End With
Next
Set oWk = Nothing
Set oExl = Nothing
Erase topR: Erase EveryR
Application.DisplayAlerts = True
End Sub

没做测试，你最好另存一下
AhmedL-avatar

AhmedL

Reply to [pid=489819103,25359716,1]Reply[/pid] Post by [uid=1754443]华麗麗[/uid] (2021-02-01 11:13)
要的要的，我回复里面上图是希望达到的效果，但是用了大佬的代码后，实际生成的学校C的文件中的内容是下面的那张图，教师90的那行数据没有了

相关话题

来娘家求助。有没有认识葡萄牙人，说葡萄牙语。现在需要采集一些葡萄牙语的声音。 来娘家求助关于Excel 来娘家求助，被物业敲诈怎么办 来娘家求助啦 笔记本选择 来娘家求助，求助怎么A上去 来娘家求助，主板后面板音频接口 来娘家求助一下，关于阅读软件 又来娘家求助，关于布光 42来娘家求助！
返回主页