Macro to send data from "Input" sheet to "Data" sheet

mark2002

New Member
Joined
Jan 19, 2023
Messages
6
Office Version
  1. 2021
Platform
  1. Windows
Hi all,
Still quite new to macros and I am having difficulty creating one that sends data from one tab (titled "Input") to the "Data" tab.

Ideally, the macro would be able to take the data from the "Input" (first image), and send it to "Data" (second image) either replacing existing data (using Shape in column A as the reference) or adding the new shape and attributes.

Essentially, it would need to function as the example below. (the highlighted cells showing the new or updated data)

Input.png
Data.png

Input 2.png
Data 2.png


Currently, my macro is only able to take the top row from the "Input" sheet and send it to the "Data" sheet.
It is unable to send multiple rows, or replace any of the 'Shape' attributes.

Input Example.png
Data Example.png


Sub Input_Button()

Dim sourceSheet As Worksheet
Dim dataSheet As Worksheet
Dim nextRow As Long

Set sourceSheet = Sheets("Input")
Set dataSheet = Sheets("Data")

nextRow = dataSheet.Range("A" & dataSheet.Rows.Count).End(xlUp).Offset(1).Row

dataSheet.Cells(nextRow, 1).Value = sourceSheet.Range("B2").Value
dataSheet.Cells(nextRow, 2).Value = sourceSheet.Range("C2").Value
dataSheet.Cells(nextRow, 3).Value = sourceSheet.Range("D2").Value


sourceSheet.Range("B2:B200").Value = ""
sourceSheet.Range("C2:C200").Value = ""
sourceSheet.Range("D2:D200").Value = ""

End Sub


Please let me know if you can help.

Thanks you so much!
-Mark
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Hi Mark,

what about

VBA Code:
Sub Input_Button()
' https://www.mrexcel.com/board/threads/macro-to-send-data-from-input-sheet-to-data-sheet.1227471/
Dim lngNextRow As Long
Dim lngCounter As Long
Dim rngNext As Range
Dim wsSrc As Worksheet
Dim wsData As Worksheet
Dim WSF As WorksheetFunction

Set wsSrc = Sheets("Input")
Set wsData = Sheets("Data")
Set WSF = WorksheetFunction

If wsSrc.Cells(wsSrc.Rows.Count, "B").End(xlUp).Row > 1 Then
  wsData.UsedRange.Offset(1).Interior.Color = xlNone
End If

For lngCounter = 2 To wsSrc.Cells(wsSrc.Rows.Count, "B").End(xlUp).Row
  If WSF.CountIf(wsData.Columns(1), wsSrc.Cells(lngCounter, 2).Value) = 0 Then
    Set rngNext = wsData.Range("A" & wsData.Rows.Count).End(xlUp).Offset(1)
    With rngNext
      .Value = wsSrc.Cells(lngCounter, "B").Value
      .Interior.ColorIndex = 6
      .Offset(0, 1).Value = wsSrc.Cells(lngCounter, "C").Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
      .Offset(0, 2).Value = wsSrc.Cells(lngCounter, "D").Value
      If Not IsEmpty(.Offset(0, 2).Value) Then .Offset(0, 2).Interior.ColorIndex = 6
    End With
  Else
    Set rngNext = wsData.Columns(1).Find(wsSrc.Cells(lngCounter, 2).Value)
    With rngNext
      .Offset(0, 1).Value = wsSrc.Cells(lngCounter, "C").Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
      If Not IsEmpty(.Offset(0, 2).Value) Or Not IsEmpty(wsSrc.Cells(lngCounter, "D").Value) Then
        .Offset(0, 2).Value = .Offset(0, 2).Value + wsSrc.Cells(lngCounter, "D").Value
        .Offset(0, 2).Interior.ColorIndex = 6
      End If
    End With
  End If
Next lngCounter

With wsSrc
  .Range("B2", .Cells(.Cells(.Rows.Count, "B").End(xlUp).Row, "D")).Value = vbNullString
End With

Set WSF = Nothing
Set wsData = Nothing
Set wsSrc = Nothing

End Sub

Ciao,
Holger
 
Upvote 0
Hi Mark,

what about

VBA Code:
Sub Input_Button()
' https://www.mrexcel.com/board/threads/macro-to-send-data-from-input-sheet-to-data-sheet.1227471/
Dim lngNextRow As Long
Dim lngCounter As Long
Dim rngNext As Range
Dim wsSrc As Worksheet
Dim wsData As Worksheet
Dim WSF As WorksheetFunction

Set wsSrc = Sheets("Input")
Set wsData = Sheets("Data")
Set WSF = WorksheetFunction

If wsSrc.Cells(wsSrc.Rows.Count, "B").End(xlUp).Row > 1 Then
  wsData.UsedRange.Offset(1).Interior.Color = xlNone
End If

For lngCounter = 2 To wsSrc.Cells(wsSrc.Rows.Count, "B").End(xlUp).Row
  If WSF.CountIf(wsData.Columns(1), wsSrc.Cells(lngCounter, 2).Value) = 0 Then
    Set rngNext = wsData.Range("A" & wsData.Rows.Count).End(xlUp).Offset(1)
    With rngNext
      .Value = wsSrc.Cells(lngCounter, "B").Value
      .Interior.ColorIndex = 6
      .Offset(0, 1).Value = wsSrc.Cells(lngCounter, "C").Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
      .Offset(0, 2).Value = wsSrc.Cells(lngCounter, "D").Value
      If Not IsEmpty(.Offset(0, 2).Value) Then .Offset(0, 2).Interior.ColorIndex = 6
    End With
  Else
    Set rngNext = wsData.Columns(1).Find(wsSrc.Cells(lngCounter, 2).Value)
    With rngNext
      .Offset(0, 1).Value = wsSrc.Cells(lngCounter, "C").Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
      If Not IsEmpty(.Offset(0, 2).Value) Or Not IsEmpty(wsSrc.Cells(lngCounter, "D").Value) Then
        .Offset(0, 2).Value = .Offset(0, 2).Value + wsSrc.Cells(lngCounter, "D").Value
        .Offset(0, 2).Interior.ColorIndex = 6
      End If
    End With
  End If
Next lngCounter

With wsSrc
  .Range("B2", .Cells(.Cells(.Rows.Count, "B").End(xlUp).Row, "D")).Value = vbNullString
End With

Set WSF = Nothing
Set wsData = Nothing
Set wsSrc = Nothing

End Sub

Ciao,
Holger


Thank you so much, this works great! It will also save me an incredible amount of time for my data entry. Two questions.
First, on the line of code that deletes the input data.
.Range("B2", .Cells(.Cells(.Rows.Count, "B").End(xlUp).Row, "D")).Value = vbNullString
If I were to add additional columns before the reference column (Shape), how could I modify it so it also also deletes out those new columns?

i.e D is now the column with "Shape".
.Range("D2", .Cells(.Cells(.Rows.Count, "B").End(xlUp).Row, "G")).Value = vbNullString

ie.png


Second, when I add number values, it currently sums them on the data sheet.
Is it possible to have the number in the input instead replace the value on the data sheet?

Thanks again!
 
Upvote 0
Hi mark2002,

you added Size as column as well...

I would slightly alter what you suggested to read

VBA Code:
  .Range("D2", .Cells(.Cells(.Rows.Count, "D").End(xlUp).Row, "G")).Value = vbNullString

as that would look for the last filled row in column D which is the area we work on (Shape is the only column thoroughly filled in the example).

Change

VBA Code:
       .Offset(0, 2).Value = .Offset(0, 2).Value + wsSrc.Cells(lngCounter, "D").Value


to

VBA Code:
       .Offset(0, 2).Value = wsSrc.Cells(lngCounter, "D").Value

to overwrite values instead of summing.

Holger
 
Upvote 0
Hi mark2002,

you added Size as column as well...

I would slightly alter what you suggested to read

VBA Code:
  .Range("D2", .Cells(.Cells(.Rows.Count, "D").End(xlUp).Row, "G")).Value = vbNullString

as that would look for the last filled row in column D which is the area we work on (Shape is the only column thoroughly filled in the example).

Change

VBA Code:
       .Offset(0, 2).Value = .Offset(0, 2).Value + wsSrc.Cells(lngCounter, "D").Value


to

VBA Code:
       .Offset(0, 2).Value = wsSrc.Cells(lngCounter, "D").Value

to overwrite values instead of summing.

Holger
Hi Holger,

Thank you, that fixed the issue of values being summed.

Unfortunately it looks like I broke the code when I added the columns 'Main Category' & 'Sub Category' and I am unsure how to fix it. (details below)

You are correct in that only the 'Shape" column will be completely filled and always have data in it for the input and should be used as the reference.

(here is an example of how the final sheet will look) (First image is the input tab, and the second image is the data tab)
Input1.png
Data1.png


When I press submit, it replaces the cells with empty cells, instead of keeping any existing value.
In the example below, the shape 'Circle' already had data for 'Main' and 'Sub Category'. However, after pushing input it replaces those with empty calues.
Input2.png
Data2.png


Finally, after input only the first row and columns D-G are removed on the input sheet. (it will also sometimes even delete the titles in cells D1 through G1 after pressing 'Input')
Input3.png


Finally, does this site have a subscription or is it possible to tip/gift those who have helped? You all have been incredibly helpful!
-Mark
(My current code below)

VBA Code:
Sub Input_Button()

Dim lngNextRow As Long
Dim lngCounter As Long
Dim rngNext As Range
Dim wsSrc As Worksheet
Dim wsData As Worksheet
Dim WSF As WorksheetFunction

Set wsSrc = Sheets("Input")
Set wsData = Sheets("Data")
Set WSF = WorksheetFunction

If wsSrc.Cells(wsSrc.Rows.Count, "D").End(xlUp).Row > 1 Then
  wsData.UsedRange.Offset(1).Interior.Color = xlNone
End If

For lngCounter = 2 To wsSrc.Cells(wsSrc.Rows.Count, "D").End(xlUp).Row
  If WSF.CountIf(wsData.Columns(3), wsSrc.Cells(lngCounter, 4).Value) = 0 Then
    Set rngNext = wsData.Range("C" & wsData.Rows.Count).End(xlUp).Offset(1)
    With rngNext
      .Value = wsSrc.Cells(lngCounter, "D").Value
      '.Interior.ColorIndex = 6
          .Offset(0, -2).Value = wsSrc.Cells(lngCounter, "B").Value
      If Not IsEmpty(.Offset(0, -2).Value) Then .Offset(0, -2).Interior.ColorIndex = 6
          .Offset(0, -1).Value = wsSrc.Cells(lngCounter, "C").Value
      If Not IsEmpty(.Offset(0, -1).Value) Then .Offset(0, -1).Interior.ColorIndex = 6
        .Offset(0, 1).Value = wsSrc.Cells(lngCounter, "E").Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
        .Offset(0, 2).Value = wsSrc.Cells(lngCounter, "F").Value
      If Not IsEmpty(.Offset(0, 2).Value) Then .Offset(0, 2).Interior.ColorIndex = 6
        .Offset(0, 3).Value = wsSrc.Cells(lngCounter, "G").Value
      If Not IsEmpty(.Offset(0, 3).Value) Then .Offset(0, 3).Interior.ColorIndex = 6
      
    End With
  Else
    Set rngNext = wsData.Columns(1).Find(wsSrc.Cells(lngCounter, 2).Value)
    With rngNext
      .Offset(0, 1).Value = wsSrc.Cells(lngCounter, "C").Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
      If Not IsEmpty(.Offset(0, 2).Value) Or Not IsEmpty(wsSrc.Cells(lngCounter, "D").Value) Then
         .Offset(0, 2).Value = wsSrc.Cells(lngCounter, "D").Value
        .Offset(0, 2).Interior.ColorIndex = 6
      End If
    End With
  End If
Next lngCounter

With wsSrc
    .Range("D2", .Cells(.Cells(.Rows.Count, "D").End(xlUp).Row, "G")).Value = vbNullString
End With

Set WSF = Nothing
Set wsData = Nothing
Set wsSrc = Nothing

End Sub
 
Upvote 0
Hi Mark,

this is what I came up with. It may look complicated to you but using constants for the columns and rewriting some of the commands should make it easier to maintain. Code is untested so report back what doesn't fit - I will take my time and check before any further answer:

VBA Code:
Sub Input_Button()

Dim lngNextRow        As Long
Dim lngCounter        As Long
Dim rngNext           As Range
Dim wsSrc             As Worksheet
Dim wsData            As Worksheet
Dim WSF               As WorksheetFunction

Const cstrColMAIN     As String = "B"
Const cstrColSUB      As String = "C"
Const cstrColSHAPE    As String = "D"
Const cstrColCOLOR    As String = "E"
Const cstrColNUMBER   As String = "F"
Const cstrColSIZE     As String = "G"

Set wsSrc = Sheets("Input")
Set wsData = Sheets("Data")
Set WSF = WorksheetFunction

If wsSrc.Cells(wsSrc.Rows.Count, "D").End(xlUp).Row > 1 Then
  wsData.UsedRange.Offset(1).Interior.Color = xlNone
End If

For lngCounter = 2 To wsSrc.Cells(wsSrc.Rows.Count, cstrColSHAPE).End(xlUp).Row
  If WSF.CountIf(wsData.Cells(1, cstrColSHAPE).EntireColumn, wsSrc.Cells(lngCounter, cstrColSHAPE).Value) = 0 Then
    Set rngNext = wsData.Range(cstrColSHAPE & wsData.Rows.Count).End(xlUp).Offset(1)
    With rngNext
      .Value = wsSrc.Cells(lngCounter, cstrColSHAPE).Value
      '.Interior.ColorIndex = 6
      
      .Offset(0, -2).Value = wsSrc.Cells(lngCounter, cstrColMAIN).Value
      If Not IsEmpty(.Offset(0, -2).Value) Then .Offset(0, -2).Interior.ColorIndex = 6
      
      .Offset(0, -1).Value = wsSrc.Cells(lngCounter, cstrColSUB).Value
      If Not IsEmpty(.Offset(0, -1).Value) Then .Offset(0, -1).Interior.ColorIndex = 6
      
      .Offset(0, 1).Value = wsSrc.Cells(lngCounter, cstrColCOLOR).Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
        
      .Offset(0, 2).Value = wsSrc.Cells(lngCounter, cstrColNUMBER).Value
      If Not IsEmpty(.Offset(0, 2).Value) Then .Offset(0, 2).Interior.ColorIndex = 6
        
      .Offset(0, 3).Value = wsSrc.Cells(lngCounter, cstrColSIZE).Value
      If Not IsEmpty(.Offset(0, 3).Value) Then .Offset(0, 3).Interior.ColorIndex = 6
    End With
  Else
    Set rngNext = wsData.Cells(1, cstrColSHAPE).EntireColumn.Find(wsSrc.Cells(lngCounter, cstrColSHAPE).Value)
    With rngNext
      .Offset(0, 1).Value = wsSrc.Cells(lngCounter, cstrColCOLOR).Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
      
      If Not IsEmpty(.Offset(0, 2).Value) Or Not IsEmpty(wsSrc.Cells(lngCounter, cstrColNUMBER).Value) Then
        .Offset(0, 2).Value = wsSrc.Cells(lngCounter, cstrColNUMBER).Value
        .Offset(0, 2).Interior.ColorIndex = 6
      End If
    End With
  End If
Next lngCounter

With wsSrc
  .Range(.Cells(2, cstrColSHAPE), .Cells(.Cells(.Rows.Count, cstrColSHAPE).End(xlUp).Row, cstrColSIZE)).Value = vbNullString
End With

Set WSF = Nothing
Set wsData = Nothing
Set wsSrc = Nothing

End Sub

At the right bottom of a post from any other person you will find a Like-Button where you can express that you find a post useful. And if the problem is solved you as threadstarter can mark the thread according to Mark as Solution.

Ciao,
Holger
 
Upvote 0
Hi Mark,

this is what I came up with. It may look complicated to you but using constants for the columns and rewriting some of the commands should make it easier to maintain. Code is untested so report back what doesn't fit - I will take my time and check before any further answer:

VBA Code:
Sub Input_Button()

Dim lngNextRow        As Long
Dim lngCounter        As Long
Dim rngNext           As Range
Dim wsSrc             As Worksheet
Dim wsData            As Worksheet
Dim WSF               As WorksheetFunction

Const cstrColMAIN     As String = "B"
Const cstrColSUB      As String = "C"
Const cstrColSHAPE    As String = "D"
Const cstrColCOLOR    As String = "E"
Const cstrColNUMBER   As String = "F"
Const cstrColSIZE     As String = "G"

Set wsSrc = Sheets("Input")
Set wsData = Sheets("Data")
Set WSF = WorksheetFunction

If wsSrc.Cells(wsSrc.Rows.Count, "D").End(xlUp).Row > 1 Then
  wsData.UsedRange.Offset(1).Interior.Color = xlNone
End If

For lngCounter = 2 To wsSrc.Cells(wsSrc.Rows.Count, cstrColSHAPE).End(xlUp).Row
  If WSF.CountIf(wsData.Cells(1, cstrColSHAPE).EntireColumn, wsSrc.Cells(lngCounter, cstrColSHAPE).Value) = 0 Then
    Set rngNext = wsData.Range(cstrColSHAPE & wsData.Rows.Count).End(xlUp).Offset(1)
    With rngNext
      .Value = wsSrc.Cells(lngCounter, cstrColSHAPE).Value
      '.Interior.ColorIndex = 6
    
      .Offset(0, -2).Value = wsSrc.Cells(lngCounter, cstrColMAIN).Value
      If Not IsEmpty(.Offset(0, -2).Value) Then .Offset(0, -2).Interior.ColorIndex = 6
    
      .Offset(0, -1).Value = wsSrc.Cells(lngCounter, cstrColSUB).Value
      If Not IsEmpty(.Offset(0, -1).Value) Then .Offset(0, -1).Interior.ColorIndex = 6
    
      .Offset(0, 1).Value = wsSrc.Cells(lngCounter, cstrColCOLOR).Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
      
      .Offset(0, 2).Value = wsSrc.Cells(lngCounter, cstrColNUMBER).Value
      If Not IsEmpty(.Offset(0, 2).Value) Then .Offset(0, 2).Interior.ColorIndex = 6
      
      .Offset(0, 3).Value = wsSrc.Cells(lngCounter, cstrColSIZE).Value
      If Not IsEmpty(.Offset(0, 3).Value) Then .Offset(0, 3).Interior.ColorIndex = 6
    End With
  Else
    Set rngNext = wsData.Cells(1, cstrColSHAPE).EntireColumn.Find(wsSrc.Cells(lngCounter, cstrColSHAPE).Value)
    With rngNext
      .Offset(0, 1).Value = wsSrc.Cells(lngCounter, cstrColCOLOR).Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
    
      If Not IsEmpty(.Offset(0, 2).Value) Or Not IsEmpty(wsSrc.Cells(lngCounter, cstrColNUMBER).Value) Then
        .Offset(0, 2).Value = wsSrc.Cells(lngCounter, cstrColNUMBER).Value
        .Offset(0, 2).Interior.ColorIndex = 6
      End If
    End With
  End If
Next lngCounter

With wsSrc
  .Range(.Cells(2, cstrColSHAPE), .Cells(.Cells(.Rows.Count, cstrColSHAPE).End(xlUp).Row, cstrColSIZE)).Value = vbNullString
End With

Set WSF = Nothing
Set wsData = Nothing
Set wsSrc = Nothing

End Sub

At the right bottom of a post from any other person you will find a Like-Button where you can express that you find a post useful. And if the problem is solved you as threadstarter can mark the thread according to Mark as Solution.

Ciao,
Holger

Hi Holger,

Thank you for sending the updated code! It
View attachment 83721

View attachment 83720
 
Upvote 0
Hi Mark,

this is what I came up with. It may look complicated to you but using constants for the columns and rewriting some of the commands should make it easier to maintain. Code is untested so report back what doesn't fit - I will take my time and check before any further answer:

VBA Code:
Sub Input_Button()

Dim lngNextRow        As Long
Dim lngCounter        As Long
Dim rngNext           As Range
Dim wsSrc             As Worksheet
Dim wsData            As Worksheet
Dim WSF               As WorksheetFunction

Const cstrColMAIN     As String = "B"
Const cstrColSUB      As String = "C"
Const cstrColSHAPE    As String = "D"
Const cstrColCOLOR    As String = "E"
Const cstrColNUMBER   As String = "F"
Const cstrColSIZE     As String = "G"

Set wsSrc = Sheets("Input")
Set wsData = Sheets("Data")
Set WSF = WorksheetFunction

If wsSrc.Cells(wsSrc.Rows.Count, "D").End(xlUp).Row > 1 Then
  wsData.UsedRange.Offset(1).Interior.Color = xlNone
End If

For lngCounter = 2 To wsSrc.Cells(wsSrc.Rows.Count, cstrColSHAPE).End(xlUp).Row
  If WSF.CountIf(wsData.Cells(1, cstrColSHAPE).EntireColumn, wsSrc.Cells(lngCounter, cstrColSHAPE).Value) = 0 Then
    Set rngNext = wsData.Range(cstrColSHAPE & wsData.Rows.Count).End(xlUp).Offset(1)
    With rngNext
      .Value = wsSrc.Cells(lngCounter, cstrColSHAPE).Value
      '.Interior.ColorIndex = 6
    
      .Offset(0, -2).Value = wsSrc.Cells(lngCounter, cstrColMAIN).Value
      If Not IsEmpty(.Offset(0, -2).Value) Then .Offset(0, -2).Interior.ColorIndex = 6
    
      .Offset(0, -1).Value = wsSrc.Cells(lngCounter, cstrColSUB).Value
      If Not IsEmpty(.Offset(0, -1).Value) Then .Offset(0, -1).Interior.ColorIndex = 6
    
      .Offset(0, 1).Value = wsSrc.Cells(lngCounter, cstrColCOLOR).Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
      
      .Offset(0, 2).Value = wsSrc.Cells(lngCounter, cstrColNUMBER).Value
      If Not IsEmpty(.Offset(0, 2).Value) Then .Offset(0, 2).Interior.ColorIndex = 6
      
      .Offset(0, 3).Value = wsSrc.Cells(lngCounter, cstrColSIZE).Value
      If Not IsEmpty(.Offset(0, 3).Value) Then .Offset(0, 3).Interior.ColorIndex = 6
    End With
  Else
    Set rngNext = wsData.Cells(1, cstrColSHAPE).EntireColumn.Find(wsSrc.Cells(lngCounter, cstrColSHAPE).Value)
    With rngNext
      .Offset(0, 1).Value = wsSrc.Cells(lngCounter, cstrColCOLOR).Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
    
      If Not IsEmpty(.Offset(0, 2).Value) Or Not IsEmpty(wsSrc.Cells(lngCounter, cstrColNUMBER).Value) Then
        .Offset(0, 2).Value = wsSrc.Cells(lngCounter, cstrColNUMBER).Value
        .Offset(0, 2).Interior.ColorIndex = 6
      End If
    End With
  End If
Next lngCounter

With wsSrc
  .Range(.Cells(2, cstrColSHAPE), .Cells(.Cells(.Rows.Count, cstrColSHAPE).End(xlUp).Row, cstrColSIZE)).Value = vbNullString
End With

Set WSF = Nothing
Set wsData = Nothing
Set wsSrc = Nothing

End Sub

At the right bottom of a post from any other person you will find a Like-Button where you can express that you find a post useful. And if the problem is solved you as threadstarter can mark the thread according to Mark as Solution.

Ciao,
Holger

Hi Holger,

*Sorry my last reply errored out.*

Thank you for the updated code! Unfortunately it appears to be off by one column. I was going to try and update it, but I didn't want to ruin anything.

Data1.png


Additionally, it still has the issue of not clearing out columns B & C on the input sheet.

Input1.png


Finally, it sometimes will delete the header text if you push input without adding input data. (Not a big issue, but just something I noticed)

Input2.png


Let me know if you need any more details.

Thank you again for all of your help!
-Mark
 
Upvote 0
Hi Mark,

I was about to answer "It for me is a song by Genesis from the album "The Lamb Lies Down on Broadway" from 1974 (last studio album with Peter Gabriel on lead vocals)."

When writing the code I forgot about the ranges being on different columns for both sheets.

Sheets Data before updating:
MrE_1227471_1701411_macro to send data_230120.xlsm
ABCDEF
1Main CategorySub CategoryShapeColorNumberSize
2CircleRed
3All ShapesTriangleGreen
4Square3
5All ShapesLarge ShapesRectangleBlue12Large
Data


Sheets Input before updating:
MrE_1227471_1701411_macro to send data_230120.xlsm
BCDEFG
1Main CategorySub CategoryShapeColorNumberSize
2Large ShapesCircleRed
3Square3
4TriangleGreen
5All ShapesStarSilver4Small
Input


Sheets Data after updating:
MrE_1227471_1701411_macro to send data_230120.xlsm
ABCDEF
1Main CategorySub CategoryShapeColorNumberSize
2CircleRed
3All ShapesTriangleGreen
4Square3
5All ShapesLarge ShapesRectangleBlue12Large
6All ShapesStarSilver4Small
Data


Sheets Input after updating:
MrE_1227471_1701411_macro to send data_230120.xlsm
BCDEFG
1Main CategorySub CategoryShapeColorNumberSize
2
Input


Code used:

Rich (BB code):
Sub Input_Button()

Dim lngNextRow        As Long
Dim lngCounter        As Long
Dim rngNext           As Range
Dim wsSrc             As Worksheet
Dim wsData            As Worksheet
Dim WSF               As WorksheetFunction

Const clngColMAIN     As Long = 2  '"B" for Input, "A" for Data
Const clngColSUB      As Long = 3  '"C"
Const clngColSHAPE    As Long = 4  '"D" <-- this is the interesting part
Const clngColCOLOR    As Long = 5  '"E"
Const clngColNUMBER   As Long = 6  '"F"
Const clngColSIZE     As Long = 7  '"G"

Set wsSrc = Sheets("Input")
Set wsData = Sheets("Data")
Set WSF = WorksheetFunction

If wsSrc.Cells(wsSrc.Rows.Count, clngColSHAPE).End(xlUp).Row > 1 Then
  wsData.UsedRange.Offset(1).Interior.Color = xlNone
End If

For lngCounter = 2 To wsSrc.Cells(wsSrc.Rows.Count, clngColSHAPE).End(xlUp).Row
  If WSF.CountIf(wsData.Cells(1, clngColSHAPE - 1).EntireColumn, wsSrc.Cells(lngCounter, clngColSHAPE).Value) = 0 Then
    Set rngNext = wsData.Cells(wsData.Rows.Count, clngColSHAPE - 1).End(xlUp).Offset(1)
    With rngNext
      .Value = wsSrc.Cells(lngCounter, clngColSHAPE).Value
      '.Interior.ColorIndex = 6
     
      .Offset(0, -2).Value = wsSrc.Cells(lngCounter, clngColMAIN).Value
      If Not IsEmpty(.Offset(0, -2).Value) Then .Offset(0, -2).Interior.ColorIndex = 6
     
      .Offset(0, -1).Value = wsSrc.Cells(lngCounter, clngColSUB).Value
      If Not IsEmpty(.Offset(0, -1).Value) Then .Offset(0, -1).Interior.ColorIndex = 6
     
      .Offset(0, 1).Value = wsSrc.Cells(lngCounter, clngColCOLOR).Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
       
      .Offset(0, 2).Value = wsSrc.Cells(lngCounter, clngColNUMBER).Value
      If Not IsEmpty(.Offset(0, 2).Value) Then .Offset(0, 2).Interior.ColorIndex = 6
       
      .Offset(0, 3).Value = wsSrc.Cells(lngCounter, clngColSIZE).Value
      If Not IsEmpty(.Offset(0, 3).Value) Then .Offset(0, 3).Interior.ColorIndex = 6
    End With
  Else
    Set rngNext = wsData.Cells(1, clngColSHAPE - 1).EntireColumn.Find(wsSrc.Cells(lngCounter, clngColSHAPE).Value)
    With rngNext
      .Offset(0, 1).Value = wsSrc.Cells(lngCounter, clngColCOLOR).Value
      If Not IsEmpty(.Offset(0, 1).Value) Then .Offset(0, 1).Interior.ColorIndex = 6
     
      If Not IsEmpty(.Offset(0, 2).Value) Or Not IsEmpty(wsSrc.Cells(lngCounter, clngColNUMBER).Value) Then
        .Offset(0, 2).Value = wsSrc.Cells(lngCounter, clngColNUMBER).Value
        .Offset(0, 2).Interior.ColorIndex = 6
      End If
    End With
  End If
Next lngCounter

With wsSrc
  .Range(.Cells(2, 2), .Cells(.Cells(.Rows.Count, clngColSHAPE).End(xlUp).Row, clngColSIZE)).Value = vbNullString
End With

Set WSF = Nothing
Set wsData = Nothing
Set wsSrc = Nothing

End Sub

I ran the code a couple of times but could no spot any headers being deleted in Sheet Input. In any case we could set up the headers at the end of the procedure like

VBA Code:
With wsSrc
  .Range(.Cells(2, 2), .Cells(.Cells(.Rows.Count, clngColSHAPE).End(xlUp).Row, clngColSIZE)).Value = vbNullString
  .Cells(1, 2).Resize(1, 6).Value = Array("Main Category", "Sub Category", "Shape", "Color", "Number", "Size")
End With

HTH,
Holger
 
Upvote 0
Hi Holger, thank you so much for all your help.
It appears to be working great for all instances except one... when I update an attribute in the column A or B it doesn't get updated on the Data sheet.

*Data sheet
Data1.png

*Input sheet
Input1.png

*Data sheet after input
data2.png


Also, due to the challenges with having the "Shape" column in the middle, what if I moved the "Shape" column to the first position?
If this would be easier, I can update the sheet to look like below.

Finalinput.png


Finaldata.png


Let me know your thoughts.
Thank you again for everything!
-Mark
 
Upvote 0

Forum statistics

Threads
1,213,490
Messages
6,113,957
Members
448,535
Latest member
alrossman

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