求大神造个vba，提取总表指定位置的数据至多个固定格式表格的指定位置

Posted 2023-04-25

如图，图1是模板，图2是汇总表，我该怎么样才能实现批量的提取汇总表内指定的数据的数据至模板指定单元格。我现在能够做出批量命名的vba但是抓取数据已经超出我的能力范围了有心无力。希望各位大神的解惑，感激不尽!!!!!!!! 例如：我想要把Sheet1的B列从上到下的顺序录入到sheet2-75的A5单元格中

你右边的表中有7列，也就是7类，也许你没有完全放上来，你先确定有多少列，也就是多少种用地性质，
然后你的模板要做全，也就是说所有的用地性质都做成单元格，
--我认为你的模版做好后，汇总表上的一行，就对应模板做成后的一张表。。也就是汇总表有多少行，分表格就做多少个，每个分表格可以做成一个文件，分表格的文件名，就是地名，对应汇总边上每一行都有一个地名，
------------一张总表，每行做一张分表---------也就是一个工作簿，分出许多工作簿----
----------好了，下边可以编程了。。。。。。思路如下：
1、遍历汇总表的每一行，每一行中的每个单元格
2、某一行：第一个单元格为地名，将模板的表格复制一份改名为该地名，
3、将这一行中的其它单元格数据，写入到以 地名 命名的工作簿的相对应的单元格中
4、去汇总表的下一行，然重复步聚3,，直到最后一行 参考技术A 做循环，判断，根据位置，偏移，定位要提取的数据量。当然，输出位置也要定位。

excel vba 代码求复制整行数据至其他表格中

判断表1的A列各单元格字体颜色是否为RGB(255,0,0)，如果是，复制整行数据到表2中

代码如下：

Sub 复制整行数据()
Dim I&, Rm&
Rm = Cells.Rows.Count
With Sheet1
   For I = 1 To .Range("A" & Rm).End(3).Row
      If .Range("A" & I).Font.Color = RGB(255, 0, 0) Then .Rows(I).Copy Sheet2.Range("A" & Rm).End(3).Offset(1)
   Next
End With
End Sub

参考技术A 以下代码你试试
sheet1 是判断的工作表 改成你自己的
sheet2 是粘贴的工作表 改成你自己的
------代码开始-------
Sub 判断复制()
Dim a%, b, c
Do
b = b + 1 '行数累加
If Sheets("Sheet1").Cells(b, 1) = "" Then Exit Do '判断单元格是否为空，为空时结束代码运行 也可以改成行数多少时结束如:if B>100 then exit sub
a = Cells(b, 1).Font.ColorIndex '获取字体颜色
If a = 3 Then '判断字体颜色是否为红色（VBA中红色是3/excel中RGB(255,0,0)是红色）
Sheets("Sheet1").Select '选中工作表
Rows(b & ":" & b).Select '判断正确选择该行
Selection.Copy '复制
Sheets("sheet2").Select '选择sheet2工作表（sheet2可以更改为其它工作表）
Range("A65536").Select
Selection.End(xlUp).Select
c = ActiveCell.Row + 1
Range("A" & c).Select '选中最后使用单元格的下一个A列的值
ActiveSheet.Paste '粘贴
Sheets("Sheet1").Select '选中判断条件的单元格
End If
Loop
Sheets("Sheet2").Select
Application.CutCopyMode = False
End Sub
------代码结束-----------