VBA Code to Remove columns and rows

Navi_G

Navi_G

Board Regular
Joined
May 30, 2018
Messages
94
Office Version
  1. 2016
Platform
  1. Windows
Hi All Expertise,
i have to make a report multiple times a day and it takes too much time because it has different steps pls provide a VBA code to do it automatically by single key or button. Step wise description:
Step 1. I go to first data sheet select from (C17:AN17) to last data row then copy it and paste in a new worksheet.
Step 2. I select 2nd data sheet from (C21:AN21) to last data row which will be between 1 to 1000, copy it and paste in that sheet where i paste 1st sheet data. (Below that data).
Step 3. Delete Row# 2 & 3.
Step 4. Delete Columns (TOTAL PCS, SHRINKAG, Width, Shade, Balance & all blanks columns).
Step 5. Copy data from (D1:Last data cell) and paste in Row # 2.
Step 6. Delete Row # 01.
Step 7. Insert Filter. Open filter in column C and delete blank rows.
Step 8. Delete column C.
Now I have only that data which I require.
Step 9. Unpivot Columns. (I have VBA code for it)
Code: 
Sub Rearrange_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, uba2 As Long
  
  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, Cells(1, Columns.Count).End(xlToLeft).Column).Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * (uba2 - 2), 1 To 4)
  For i = 2 To UBound(a)
    For j = 3 To uba2
      If Len(a(i, j)) > 0 Then
        k = k + 1
        b(k, 1) = a(i, 1)
        b(k, 2) = a(i, 2)
        b(k, 3) = a(1, j)
        b(k, 4) = a(i, j)
      End If
    Next j
  Next i
  Range("A" & Rows.Count).End(xlUp).Offset(3).Resize(, 4).Value = Array("QTY", "CUT #", "Size", "Bundle")
  Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 4).Value = b
End Sub
Step 10. Some cuts have more than on value row assign them numbering. (I have VBA for this
Code: 
Sub Bundles()
       
       Dim vWS As Worksheet
       Dim vA, vA2()
       Dim vR As Long, vSum As Long, vC As Long
       Dim vN As Long, vN2 As Long, vN3 As Long
       
       Set vWS = ActiveSheet
       With vWS
              vR = .Cells(Rows.Count, 4).End(xlUp).Row
              vSum = Application.Sum(.Range("D2:D" & vR))
              ReDim Preserve vA2(1 To vSum, 1 To 4)
              vA = .Range("A2:D" & vR)
              For vN = 1 To vR - 1
                     For vN2 = 1 To vA(vN, 4)
                            vC = vC + 1
                            For vN3 = 1 To 4
                                   vA2(vC, vN3) = vA(vN, vN3)
                            Next vN3
                     Next vN2
              Next vN
       End With
       vC = 1
       For vN = 1 To vSum - 2
              vA2(vN, 4) = vC
              If vA2(vN + 1, 2) = vA2(vN, 2) Then
                     vC = vC + 1
                     vA2(vN + 1, 4) = vC
              Else
                     vA2(vN + 1, 4) = 1
                     vC = 1
              End If
       Next vN
       Application.ScreenUpdating = False
       Sheets.Add
       With ActiveSheet
                     vWS.Range("A1:D1").Copy .Range("A1:D1")
                     .Cells(2, 1).Resize(vSum, 4) = vA2
       End With
       Application.ScreenUpdating = True
       
End Sub
Kindly give VBA coding to remove unnecessary rows and columns and also compile all coding in one.
Data Sheets may be 1 to 15.
Link of my data file is
GU 15436 15437 15542 15543.xlsx

i have already post this question in Excel Forum but enable to get any answer.
Remove Un-Necessary Data by VBA
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Sort by date Sort by votes
Are you have only Data Sheets In your workbook?
 
Upvote 0
Without Deleting other sheets, For Step 1 to 8 Try this code:
VBA Code: 
Sub RefineData()
Dim i As Long, j As Long, Lr As Long, LrD As Long, N As Long, vWS As Worksheet, vR As Long
Dim a As Variant, b As Variant, k As Long, uba2 As Long, vSum As Long, vC As Long
Dim vN As Long, vN2 As Long, vN3 As Long, vA, vA2()
 Application.ScreenUpdating = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Result"
For i = 1 To ThisWorkbook.Sheets.Count - 1
If Sheets(i).Range("C20").Value = "TOTAL PCS" Then
Lr = Sheets(i).Range("D21").End(xlDown).Row
If Lr = Rows.Count Then GoTo Step2
LrD = Sheets("Result").Range("B" & Rows.Count).End(xlUp).Row + 1
If LrD = 2 Then
Sheets(i).Range("C17:AN" & Lr).Copy
Sheets("Result").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
Sheets(i).Range("C21:AN" & Lr).Copy
Sheets("Result").Range("A" & LrD).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Step2:
End If
Next i
If Sheets("Result").Range("H4").Value = "" Then
Sheets("Result").Range("H4").Value = Sheets("Result").Range("G4").Value
Sheets("Result").Range("G4").Value = ""
End If
Sheets("Result").Rows("2:3").Delete
For i = 11 To 1 Step -1
  Select Case Trim(Sheets("Result").Cells(2, i).Value)
   Case "TOTAL PCS", "SHRINKAG", "Width", "Shade", "Balance", ""
    Sheets("Result").Columns(i).Delete
   End Select
Next i
Sheets("Result").Range("D2:N2").Value = Sheets("Result").Range("D1:N1").Value
Sheets("Result").Rows("1").Delete
For i = Sheets("Result").Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
N = Sheets("Result").Range("C" & Sheets("Result").Range("C" & Rows.Count).End(xlUp).Row).End(xlUp).Row - 1
If N < 2 Then GoTo Step10
Sheets("Result").Rows(N).Delete
Next i
Step10:
Sheets("Result").Columns(3).Delete
Application.ScreenUpdating = True
End Sub
Then Run Other Codes.
 
Upvote 0
Or try this code for All Step1 to 10:
VBA Code: 
Sub RefineData2()
Dim i As Long, j As Long, Lr As Long, LrD As Long, N As Long, vWS As Worksheet, vR As Long
Dim a As Variant, b As Variant, k As Long, uba2 As Long, vSum As Long, vC As Long
Dim vN As Long, vN2 As Long, vN3 As Long, vA, vA2()
 Application.ScreenUpdating = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Result"
For i = 1 To ThisWorkbook.Sheets.Count - 1
If Sheets(i).Range("C20").Value = "TOTAL PCS" Then
Lr = Sheets(i).Range("D21").End(xlDown).Row
If Lr = Rows.Count Then GoTo Step2
LrD = Sheets("Result").Range("B" & Rows.Count).End(xlUp).Row + 1
If LrD = 2 Then
Sheets(i).Range("C17:AN" & Lr).Copy
Sheets("Result").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
Sheets(i).Range("C21:AN" & Lr).Copy
Sheets("Result").Range("A" & LrD).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Step2:
End If
Next i
If Sheets("Result").Range("H4").Value = "" Then
Sheets("Result").Range("H4").Value = Sheets("Result").Range("G4").Value
Sheets("Result").Range("G4").Value = ""
End If
Sheets("Result").Rows("2:3").Delete
For i = 11 To 1 Step -1
  Select Case Trim(Sheets("Result").Cells(2, i).Value)
   Case "TOTAL PCS", "SHRINKAG", "Width", "Shade", "Balance", ""
    Sheets("Result").Columns(i).Delete
   End Select
Next i
Sheets("Result").Range("D2:N2").Value = Sheets("Result").Range("D1:N1").Value
Sheets("Result").Rows("1").Delete
For i = Sheets("Result").Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
N = Sheets("Result").Range("C" & Sheets("Result").Range("C" & Rows.Count).End(xlUp).Row).End(xlUp).Row - 1
If N < 2 Then GoTo Step10
Sheets("Result").Rows(N).Delete
Next i
Step10:
Sheets("Result").Columns(3).Delete
With Sheets("Result")
  a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * (uba2 - 2), 1 To 4)
  For i = 2 To UBound(a)
    For j = 3 To uba2
      If Len(a(i, j)) > 0 Then
        k = k + 1
        b(k, 1) = a(i, 1)
        b(k, 2) = a(i, 2)
        b(k, 3) = a(1, j)
        b(k, 4) = a(i, j)
      End If
    Next j
  Next i
  Lr = .Range("A" & Rows.Count).End(xlUp).Row
  LrD = .Cells(1, Columns.Count).End(xlToLeft).Column
  Range(.Cells(1, 1), .Cells(Lr, LrD)).ClearContents
  .Range("A" & Rows.Count).End(xlUp).Resize(, 4).Value = Array("QTY", "CUT #", "Size", "Bundle")
  .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 4).Value = b
    
    vR = .Cells(Rows.Count, 4).End(xlUp).Row
    vSum = Application.Sum(.Range("D2:D" & vR))
     ReDim Preserve vA2(1 To vSum, 1 To 4)
    vA = .Range("A2:D" & vR)
      For vN = 1 To vR - 1
        For vN2 = 1 To vA(vN, 4)
          vC = vC + 1
           For vN3 = 1 To 4
             vA2(vC, vN3) = vA(vN, vN3)
           Next vN3
        Next vN2
      Next vN
 End With
       
  vC = 1
   For vN = 1 To vSum - 2
    vA2(vN, 4) = vC
     If vA2(vN + 1, 2) = vA2(vN, 2) Then
      vC = vC + 1
      vA2(vN + 1, 4) = vC
     Else
      vA2(vN + 1, 4) = 1
      vC = 1
     End If
   Next vN
 Sheets.Add(After:=Sheets(Sheets.Count)).Name = "FinalResult"
   With ActiveSheet
        Sheets("Result").Range("A1:D1").Copy .Range("A1:D1")
       .Cells(2, 1).Resize(vSum, 4) = vA2
  End With
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
Dear Expert,
Thanks a lot for this help its amazing.
 
Upvote 0
Dear Expert,
Sorry for disturbing again your given code is awesome but is not working in following type sheet can you pls check.

GU 15368.xlsx
 
Upvote 0
Try this For Both Files:
VBA Code: 
Sub RefineData3()
Dim i As Long, j As Long, Lr As Long, LrD As Long, N As Long, vWS As Worksheet, vR As Long
Dim a As Variant, b As Variant, k As Long, uba2 As Long, vSum As Long, vC As Long
Dim vN As Long, vN2 As Long, vN3 As Long, vA, vA2()
 Application.ScreenUpdating = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Result"
For i = 1 To ThisWorkbook.Sheets.Count - 1
If Sheets(i).Range("C20").Value = "TOTAL PCS" Then
Lr = Sheets(i).Range("D21").End(xlDown).Row
If Lr = Rows.Count Then GoTo Step2
Debug.Print Sheets(i).Name
LrD = Sheets("Result").Range("B" & Rows.Count).End(xlUp).Row + 1
If LrD = 2 Then
Sheets(i).Range("C17:AN" & Lr).Copy
Sheets("Result").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
Sheets(i).Range("C21:AN" & Lr).Copy
Sheets("Result").Range("A" & LrD).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Step2:
End If
Next i
If Sheets("Result").Range("H4").Value = "" Then
Sheets("Result").Range("H4").Value = Sheets("Result").Range("G4").Value
Sheets("Result").Range("G4").Value = ""
End If
Sheets("Result").Rows("2:3").Delete
For i = 11 To 1 Step -1
  Select Case Trim(Sheets("Result").Cells(2, i).Value)
   Case "TOTAL PCS", "SHRINKAG", "Width", "Shade", "Balance", ""
    Sheets("Result").Columns(i).Delete
   End Select
Next i
With Sheets("Result")
.Range("D2:AN2").Value = .Range("D1:AN1").Value
.Rows("1").Delete
LrD = .Range("B" & Rows.Count).End(xlUp).Row
  .Range("A1:AN" & LrD).AutoFilter Field:=3, Criteria1:="<>"
  .Range("A1:AN" & LrD).SpecialCells(xlCellTypeVisible).Copy
  .Range("A" & LrD + 1).Select
   ActiveSheet.Paste
  .Range("A1:AN" & LrD).AutoFilter
  .Rows("1:" & LrD).Delete
  .Columns(3).Delete
  
  a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * (uba2 - 2), 1 To 4)
  For i = 2 To UBound(a)
    For j = 3 To uba2
      If Len(a(i, j)) > 0 Then
        k = k + 1
        b(k, 1) = a(i, 1)
        b(k, 2) = a(i, 2)
        b(k, 3) = a(1, j)
        b(k, 4) = a(i, j)
      End If
    Next j
  Next i
  Lr = .Range("A" & Rows.Count).End(xlUp).Row
  LrD = .Cells(1, Columns.Count).End(xlToLeft).Column
  Range(.Cells(1, 1), .Cells(Lr, LrD)).ClearContents
  .Range("A" & Rows.Count).End(xlUp).Resize(, 4).Value = Array("QTY", "CUT #", "Size", "Bundle")
  .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 4).Value = b
    
    vR = .Cells(Rows.Count, 4).End(xlUp).Row
    vSum = Application.Sum(.Range("D2:D" & vR))
     ReDim Preserve vA2(1 To vSum, 1 To 4)
    vA = .Range("A2:D" & vR)
      For vN = 1 To vR - 1
        For vN2 = 1 To vA(vN, 4)
          vC = vC + 1
           For vN3 = 1 To 4
             vA2(vC, vN3) = vA(vN, vN3)
           Next vN3
        Next vN2
      Next vN
 End With
       
  vC = 1
   For vN = 1 To vSum - 2
    vA2(vN, 4) = vC
     If vA2(vN + 1, 2) = vA2(vN, 2) Then
      vC = vC + 1
      vA2(vN + 1, 4) = vC
     Else
      vA2(vN + 1, 4) = 1
      vC = 1
     End If
   Next vN
 Sheets.Add(After:=Sheets(Sheets.Count)).Name = "FinalResult"
   With ActiveSheet
        Sheets("Result").Range("A1:D1").Copy .Range("A1:D1")
       .Cells(2, 1).Resize(vSum, 4) = vA2
  End With
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thanks a lot its working properly thanks again.
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question Question
VBA change cell colour
2
Replies
17
Views
959
kevin9999
K
O
  • Solved
Put amount in DEBIT,CREDIT columns based on matching part of item
Replies
9
Views
207
Omran Y
O
2
  • Question Question
Compare columns with discontinuous data.
Replies
3
Views
135
24August
2
M
  • Question Question
Operational Risk Methodology on VBA
Replies
0
Views
123
Mazurofgod
M
D
  • Question Question
VBA Code to split week ranges into separate lines (additional code required)
Replies
0
Views
554
DotExcel
D

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top