Excel·VBA表格横向、纵向相互转换

news2024/11/20 14:36:32

在这里插入图片描述
如图:对图中区域 A1:M6 横向表格,转换成区域 A1:C20 纵向表格,即 B:M 列转换成每2列一组按行写入,并删除空行。同理,反向操作就是纵向表格转换成横向表格

目录

    • 横向转纵向
      • 实现方法1
        • 转换结果
      • 实现方法2
        • 转换结果
    • 纵向转横向
      • 转换结果

横向转纵向

实现方法1

本文图1中,按“交期和交货数量”每5行2列为一组,依次按行写入,即按“交期”顺序排列

Sub 表格横向转纵向1()
    '分段转换,转换列之前同名不连续;不使用动态获取每行最后一列是考虑到部分选中拆分
    Dim num_col&, title_row&, del_empty As Boolean, rng As Range, del_rng As Range
    Dim first_col&, resize_r&, resize_c&, keep_rng, arr, brr, b$, r&, i&, j&
'--------------------参数填写:num_col、title_row都为数字,选中后才可运行代码
    num_col = 2    '需要拆分的数据每行固定的列数
    title_row = 1  '表头行数
    del_empty = True  '是否删除空行
    If Selection.Count = 1 Then Debug.Print "未选中列,无法运行代码": Exit Sub
    Set rng = Intersect(ActiveSheet.UsedRange, Selection)  'intersect语句避免选择整列造成无用计算
    '选中区域开始列号,转换行数、列数
    first_col = rng.column: resize_r = rng.Rows.Count - title_row: resize_c = rng.Columns.Count
    If resize_c Mod num_col <> 0 Then Debug.Print "选中列数不可平分": Exit Sub
    
    With ActiveSheet
        keep_rng = .Cells(title_row + 1, 1).Resize(resize_r, first_col - 1)  '不变区域
        arr = .Cells(title_row + 1, first_col).Resize(resize_r, resize_c)    '转换区域
        r = title_row + 1  '写入行号
        For i = num_col + 1 To UBound(arr, 2) Step num_col
            r = r + resize_r: .Cells(r, 1).Resize(resize_r, first_col - 1) = keep_rng
            For j = 1 To num_col
                brr = Application.index(arr, , i + j - 1)  '按列拆分
                .Cells(r, first_col + j - 1).Resize(resize_r, 1) = brr
            Next
        Next
        If del_empty Then  '删除空行
            For i = title_row + 1 To r + resize_r
                brr = .Cells(i, first_col).Resize(1, num_col)
                b = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(brr)), "")
                If Len(b) = 0 Then
                    If del_rng Is Nothing Then
                        Set del_rng = .Rows(i)
                    Else
                        Set del_rng = Union(del_rng, .Rows(i))
                    End If
                End If
            Next
            If Not del_rng Is Nothing Then del_rng.Delete  '删除行
        End If
        .Cells(1, first_col + num_col).Resize(1, resize_c - num_col).EntireColumn.Delete  '删除选中列
    End With
End Sub

转换结果

本文图1(转换前不含7-20行),选中 B:M 列,运行代码得到如下图结果: D:M 列被删除
在这里插入图片描述

实现方法2

本文图1中,按“产品规格”每个产品后面6组“交期和交货数量”转换为每6行2列,依次按行写入,即按“产品”顺序排列

以下代码使用了数组行列数转换函数,调用了wraparr函数,代码详见《Excel·VBA单元格区域行列数转换函数》(如需使用代码需复制)

Sub 表格横向转纵向2()
    '按行转换,转换列之前同名连续;不使用动态获取每行最后一列是考虑到部分选中拆分
    Dim num_col&, title_row&, del_empty As Boolean, rng As Range, del_rng As Range
    Dim first_col&, last_row&, resize_r&, resize_c&, keep_rng, arr, brr, b$, r&, i&, j&
'--------------------参数填写:num_col、title_row都为数字,选中后才可运行代码
    num_col = 2    '需要拆分的数据每行固定的列数
    title_row = 1  '表头行数
    del_empty = True  '是否删除空行
    If Selection.Count = 1 Then Debug.Print "未选中列,无法运行代码": Exit Sub
    Set rng = Intersect(ActiveSheet.UsedRange, Selection)  'intersect语句避免选择整列造成无用计算
    '选中区域开始列号、结束行号,转换行数、列数
    first_col = rng.column: last_row = rng.Rows.Count
    resize_r = rng.Rows.Count - title_row: resize_c = rng.Columns.Count: r = resize_c / num_col
    If resize_c Mod num_col <> 0 Then Debug.Print "选中列数不可平分": Exit Sub
    
    With ActiveSheet
        For i = last_row To title_row + 1 Step -1  '倒序循环
            keep_rng = .Cells(i, 1).Resize(1, first_col - 1)  '不变区域
            arr = .Cells(i, first_col).Resize(1, resize_c)    '转换区域
            arr = wraparr(arr, "row", r)  '调用函数将arr转换为r行num_col的数组
            .Cells(i + 1, 1).Resize(r - 1, 1).EntireRow.Insert  '插入行
            .Cells(i, 1).Resize(r, first_col - 1) = keep_rng
            .Cells(i, first_col).Resize(r, num_col) = arr
        Next
        If del_empty Then  '删除空行
            j = (last_row - title_row) * r + title_row  '总行数
            For i = title_row + 1 To j
                brr = .Cells(i, first_col).Resize(1, num_col)
                b = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(brr)), "")
                If Len(b) = 0 Then
                    If del_rng Is Nothing Then
                        Set del_rng = .Rows(i)
                    Else
                        Set del_rng = Union(del_rng, .Rows(i))
                    End If
                End If
            Next
            If Not del_rng Is Nothing Then del_rng.Delete  '删除行
        End If
        .Cells(1, first_col + num_col).Resize(1, resize_c - num_col).EntireColumn.Delete  '删除选中列
    End With
End Sub

转换结果

本文图1(转换前不含7-20行),选中 B:M 列,运行代码得到如下图结果: D:M 列被删除
在这里插入图片描述

纵向转横向

使用自定义函数转换,具体说明见注释(key_col(0)为开始列号,之前的都为字典键,之后的都为待转换数据)

Function 纵向转横向(ByVal data_arr, ByVal key_col)  '按非key_col列为键横向合并数组
    '转换函数,arr为待转换数组(从1开始计数二维数组),key_col为列号数组(从0开始计数一维数组)
    '返回结果,从1开始计数二维数组;key_col(0)为开始列号,key_col(1)为结束列号,键在开始列号之前
    Dim dict As Object, num_col&, delimiter$, i&, j&, r&, c&, k$, max_c&, rr&, cc&
    If Not IsArray(data_arr) Or Not IsArray(key_col) Then Debug.Print "错误!参数都为数组": Exit Function
    Set dict = CreateObject("scripting.dictionary")
    num_col = key_col(1) - key_col(0) + 1: delimiter = Chr(28)  '分隔符
    ReDim res(1 To UBound(data_arr), 1 To UBound(data_arr) * num_col)
    
    For i = LBound(data_arr) To UBound(data_arr)
        k = ""
        For j = 1 To key_col(0) - 1
            k = k & delimiter & data_arr(i, j)
        Next
        If Not dict.Exists(k) Then
            r = r + 1: dict(k) = Array(r, key_col(0))
            For j = 1 To key_col(0) - 1
                res(r, j) = data_arr(i, j)
            Next
        Else
            c = dict(k)(1) + num_col: dict(k) = Array(dict(k)(0), c)
            max_c = WorksheetFunction.Max(max_c, c)  '最大列数
        End If
        rr = dict(k)(0): cc = dict(k)(1) - 1
        For j = key_col(0) To key_col(1)
            cc = cc + 1: res(rr, cc) = data_arr(i, j)
        Next
    Next
    ReDim result(1 To r, 1 To max_c + num_col - 1)  '去除res数组多余部分
    For i = 1 To UBound(result)
        For j = 1 To UBound(result, 2)
            result(i, j) = res(i, j)
        Next
    Next
    纵向转横向 = result
End Function

转换结果

对“横向转纵向”无论是方法1还是方法2,生成的结果进行如下转换,生成的“纵向转横向”结果都一致,如下图

Sub 表格纵向转横向()
    Dim arr, brr
    arr = [a2:c20]: brr = 纵向转横向(arr, Array(2, 3))
    [d1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

在这里插入图片描述
多列键也可使用自定义函数转换,更具通用性

Sub 表格纵向转横向()
    Dim arr, brr
    arr = [a2:d20]: brr = 纵向转横向(arr, Array(3, 4))
    [f1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

在这里插入图片描述

扩展阅读:
《excelhome-多列转3列》
《excel吧-3列转多列》

本文来自互联网用户投稿,该文观点仅代表作者本人,不代表本站立场。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如若转载,请注明出处:http://www.coloradmin.cn/o/830354.html

如若内容造成侵权/违法违规/事实不符,请联系多彩编程网进行投诉反馈,一经查实,立即删除!

相关文章

Socket层代码重构

src/utils新建socket.js import {io} from "socket.io-client"class Socket{constructor(){this.socket io("http://127.0.0.1:5000");}// 连接socketconnect(){this.socket.connect()}login(username,callback){// emit发送this.socket.emit(login,{&quo…

list交并补差集合

list交并补差集合 工具类依赖 <dependency><groupId>org.apache.commons</groupId><artifactId>commons-lang3</artifactId><version>3.8.1</version> </dependency><dependency><groupId>commons-collections&…

并发编程Part 2

1. JMM 问题&#xff1a;请你谈谈你对volatile的理解? volitile 是 Java 虚拟机提供的一种轻量级的同步机制 &#xff0c;三大特性&#xff1a; 保证可见性 不保证原子性 禁止指令重排 线程之间如何通信&#xff1f; 通信是指线程之间以如何来交换信息。一般线程之间的通信…

HTML+CSS+JavaScript:随机点名案例

一、需求 1、点击开始按钮&#xff0c;姓名随机切换 2、点击结束按钮&#xff0c;姓名停止切换&#xff0c;此时显示的姓名即为被抽中者 3、同一个人不能被重复抽中 二、代码素材 以下是缺失JS部分的代码&#xff0c;感兴趣的小伙伴可以先自己试着写一写 <!DOCTYPE htm…

Scrum.org-ScrumMaster认证课-PSM培训

在敏捷学习的道路上继续前行&#xff0c;Leangoo领歌的PSM课程已经开启&#xff0c;认证全球认可&#xff0c;还不用续证&#xff0c;可以了解一下。 Scrum是目前运用最为广泛的敏捷开发方法&#xff0c;是一个轻量级的项目管理和产品研发管理框架&#xff0c;旨在最短时间内交…

Elasticsearch 商业启示

上月的“红帽事件”&#xff0c;说明开源软件的“客服模式”行不通&#xff0c;那么&#xff0c;开源软件如何赚钱呢&#xff1f;既不能卖软件&#xff0c;又不能卖支持服务&#xff0c;该怎么办呢&#xff1f;我现在的看法是&#xff0c;只剩下一种模式是可行的&#xff0c;开…

Windows用户如何安装新版本cpolar内网穿透超详细教程

Windows用户如何安装新版本cpolar内网穿透 文章目录 Windows用户如何安装新版本cpolar内网穿透 在科学技术高度发达的今天&#xff0c;我们身边充斥着各种电子产品&#xff0c;这些电子产品不仅为我们的工作带来极大的便利&#xff0c;也让生活变得丰富多彩。我们可以使用便携的…

方法论揭秘|研发数字化转型,这家保险企业做对了什么?

7月27日&#xff0c;FCS 2023 第 7 届中国金融 CIO 峰会&#xff08;深圳站&#xff09;如期举行。大会以「洞见智慧金融」为主题&#xff0c;深度解读中国金融行业数字化转型现状&#xff0c;探讨金融行业信息化趋势、数字供应链金融服务、金融科技创新等问题&#xff0c;期望…

js:使用LetterAvatar通过canvas实现浏览器中生成字母头像

实现效果 LetterAvatar的原理就是利用了浏览器对象canvas 在线体验&#xff1a;https://mouday.github.io/tools/pages/letter-avatar/index.html LetterAvatar.js 完整代码 /** LetterAvatar* * Artur Heinze* Create Letter avatar based on Initials* based on https:/…

环形链表的进一步探究

茕茕白兔&#xff0c;东走西顾&#xff0c;衣不如新&#xff0c;人不如故 往期回顾&#xff1a; 数据结构——双向链表 数据结构——单链表 数据结构——顺序表 文章目录 如何判断一个链表是否为环形链表 环形链表的判断的深入探究 例1&#xff1a;沸羊羊追美羊羊 例…

多线程案例(3)

文章目录 多线程案例三三、 定时器 大家好&#xff0c;我是晓星航。今天为大家带来的是 多线程案例三 相关的讲解&#xff01;&#x1f600; 多线程案例三 三、 定时器 定时器是什么 定时器也是软件开发中的一个重要组件. 类似于一个 “闹钟”. 达到一个设定的时间之后, 就…

AgileBoot - 全栈项目启动

AgileBoot-Back-End: 基于Ruoyi做了大量重构优化的基础快速开发框架。采用Springboot Vue 3 Mybatis Plus 更面向对象的业务建模 面向生产的项目。&#xff08;非玩具项目&#xff09; 首先克隆代码&#xff0c;同是克隆前端和后端的代码。 前端代码启动&#xff1a; np…

机器学习---概述(二)

文章目录 1.模型评估1.1 分类模型评估1.2 回归模型评估 2. 拟合2.1 欠拟合2.2 过拟合2.3 适当拟合总结&#xff1a; 3.深度学习3.1层次&#xff08;Layers&#xff09;&#xff1a;3.2 神经元&#xff08;Neurons&#xff09;&#xff1a;3.3 总结 1.模型评估 模型评估是机器学…

【2种方法,jmeter用一个正则提取器提取多个值!】

jmeter中&#xff0c;用json提取器&#xff0c;一次提取多个值&#xff0c;这个很多人都会。但是&#xff0c;用正则提取器一次提取多个&#xff0c;是否可以呢&#xff1f; 肯定&#xff0c;很多人都自信满满的说&#xff0c;可以&#xff01;形如&#xff1a;token":&q…

MC0111配速MC0112白日梦Ⅰ

MC0111配速 难度&#xff1a; 白银 时间限制&#xff1a;1秒 占用内存&#xff1a;128M 小码哥参加了学校的定向越野比赛&#xff0c;赛完后&#xff0c;他踌躇满志地拿着自己的成绩单&#xff0c;看着一段段的数据&#xff0c;想算一下自己整场比赛的平均配速是多少。…

无涯教程-Lua - 嵌套if语句函数

在Lua编程中&#xff0c;您可以在另一个if or else if语句中使用一个if or else if语句。 nested if statements - 语法 嵌套if 语句的语法如下- if( boolean_expression 1) then--[ Executes when the boolean expression 1 is true --]if(boolean_expression 2)then--[ Ex…

【腾讯云 Cloud Studio 实战训练营】基于Cloud Studio 通过Java实现和公众号的快速对接

目录 一、Cloud Studio是什么 1.1 Cloud Studio介绍 1.2 Cloud Studio功能特点 1.3 Cloud Studio的好处 二、实战案例 2.1 创建开发环境 2.2选择开发模板 2.3 代码编写 2.3.1 引入依赖包 2.3.2 创建Models配置类 2.3.3 创建测试类demo.java 三、使用总结 今天通过J…

数论—换元法

0x00 前言 换元法指将一个式子看做一个整体&#xff0c;进行整体运算&#xff0c;从而达到简化的目的。 0x01 例题&#xff1a; 1.求所有整数n&#xff0c;使得n1|n25 2.求所有整数n&#xff0c;使得n-2|n5n 同样使用n-2去换元即可。 3.求所有的整数n&#xff0c;使用n-1|…

c语言基础知识帮助理解(函数递归详解)

"从前有座山&#xff0c;山里有座庙&#xff0c;庙里有个老和尚和一个小和尚。有一天老和尚对小和尚说:“从前有座山.山里有座庙&#xff0c;庙里有个老和尚和一个小和尚&#xff0c;有一天老和尚对小和尚说&#xff1a;“从前有座山.山里有座庙&#xff0c;庙里有个老和尚…

uniapp返回

// 监听返回事件onNavigationBarButtonTap() {uni.showModal({title: 提示,content: 确定要返回吗&#xff1f;,success: (res) > {if (res.confirm) {uni.navigateBack({delta: 2})}}})},